Transferring Wide Data to Long Data

[ipmh97]

Hi,

Currently, my excel sheet is composed of data that are not in long format.
28970

I want to cut the data to paste at the bottom of the first 2 columns to get something like this:
28971

I have written some vba code to allow me to do the cutting and pasting. However, the code doesn't seem to exit the Find Loop and continuously finds and cuts. I want to stop finding after all columns after the 1st 2 are cut and pasted to the bottom. What edits can I make to the code to allow the find to escape the loop? Thank you


Sub FindTextInSheets()
Dim FirstAddress As String
Dim myColor As Variant
Dim rng As Range
Dim Corp As Range
Dim rowscount As Variant
Dim rowsno As Integer
Set rng = ActiveSheet.Cells.Find(What:="Code", _
After:=Range("B1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
rng.Select
Range(Selection, Selection.Offset(0, 1)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("A1").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
Set rng = ActiveSheet.Cells.FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If

End Sub

[snb]

Did you ever hear of autofilter ?

[p45cal]

try changing:
Selection.Cut
to:
Intersect(Selection, Selection.Offset(1)).Cut

and:
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
to:
Loop While Not rng Is Nothing And rng.Address <> FirstAddress And rng.Address <> "$A$1"

[Paul_Hossler]

Option Explicit

Sub Wide2Long()
Dim rWide As Range, rLong As Range
Dim i As Long
Dim wsLong As Worksheet


Set rWide = ActiveSheet.Cells(1, 1).CurrentRegion


Worksheets.Add
Set wsLong = ActiveSheet

wsLong.Cells(1, 1).Value = rWide.Cells(1, 1)
wsLong.Cells(1, 2).Value = rWide.Cells(1, 2)

Set rWide = rWide.Cells(2, 1).Resize(rWide.Rows.Count - 1, rWide.Columns.Count)


For i = 1 To rWide.Columns.Count - 1 Step 2
Set rLong = wsLong.Cells(wsLong.Rows.Count, 1).End(xlUp).Offset(1, 0)
rWide.Columns(i).Resize(, 2).Copy rLong
Next i
End Sub


The color coding was so I could check

[mancubus]

i worked on an array solution but, upon receiving an 'urgent' email, forgot to post.
posting now as an alternative for those who may need in the future.



Sub vbax_69185_convert_multi_col_data_to_2col_data()

Dim wArr, lArr
Dim i As Long

With Worksheets("Sheet1").Range("A1").CurrentRegion
wArr = .Offset(1).Resize(.Rows.Count - 1).Value
End With

With Worksheets("Sheet2")
For i = UBound(wArr, 1) To UBound(wArr, 2) Step 2
lArr = Application.Index(wArr, Evaluate("ROW(1:" & UBound(wArr, 1) & ")"), Array(i, i + 1))
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(lArr, 1), UBound(lArr, 2)).Value = lArr
Next

'col headers
.Range("A1").Value = Worksheets("Sheet1").Range("A1").Value
.Range("B1").Value = Worksheets("Sheet1").Range("B1").Value
End With

End Sub


change Step 2 to Step 3
and Array(i, i + 1) to Array(i, i + 1, i + 2)
in cases where you may need 3 columns conversion

[snb]

Or:

Sub M_snb()
sn = Sheet2.Cells(1).CurrentRegion
ReDim sp(29, 2 * ((UBound(sn) - 1) \ 29 + 1))

For j = 2 To UBound(sn)
y = Array((j - 2) Mod 29 + 1, (j - 2) \ 29)
sp(0, 2 * y(1)) = sn(1, 1)
sp(0, 2 * y(1) + 1) = sn(1, 2)
sp(y(0), 2 * y(1)) = sn(j, 1)
sp(y(0), 2 * y(1) + 1) = sn(j, 2)
Next

Sheet2.Cells(1, 4).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
End Sub