Transferring Wide Data to Long Data

[ipmh97]

Hi,

Currently, my excel sheet is composed of data that are not in long format.
Screenshot 2021-09-16 at 4.32.49 PM.jpg

I want to cut the data to paste at the bottom of the first 2 columns to get something like this:
Screenshot 2021-09-16 at 4.33.00 PM.jpg

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