Transpose data from wide format to long format excel

[ipmh35]

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

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



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

 

[Fluff]

Do you want the header row copied with the rest of the data?

 

[ipmh35]

Do you want the header row copied with the rest of the data?

Ideally nope, I just want the data from row b onwards to be copied and the header deleted after

 

[Fluff]

Ok, how about

Sub ipmh()
   Dim i As Long
   
   For i = 3 To Cells(1, Columns.Count).End(xlToLeft).Column Step 2
      Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp)).Resize(, 2).Cut Range("A" & Rows.Count).End(xlUp).Offset(1)
   Next i
   Range("C1").Resize(, i + 1).Value = ""
End Sub

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Transferring Wide Data to Long Data
and Transpose data from wide format to long format excel - OzGrid Free Excel/VBA Help Forum

If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[ipmh35]

Yes this works thank you!

 

[Fluff]

You're welcome & thanks for the feedback.