Looping Through 2 Columns & Copying 2nd Column's Data Under the First-CodePudding

I am trying to create a list with 2 columns by placing the values from the 2nd column under the first on a new tab. In my screenshot I have column A "Data 1" and column B "Data 2". Each value under Data 1 has a corresponding value under Data 2. I am trying to make it look like the Second Tab column where the value under Data 1 is copied over first then Data 2 is Copied underneath. There are blanks in between values so im trying to figure out a way to capture all the data excluding the blanks so its 1 organized list. I have tried the following so far but i cant figure it out:

Sample Results

Sub MoveData()

Dim wb As Workbook: Set wb = ThisWorkbook

For i = 1 To 15

wb.Sheets("Sheet1").Range("A2:A" & i).Copy Destination:=wb.Sheets("Sheet2").Range("A1")

wb.Sheets("Sheet1").Range("A2:A" & i).Offset(0, 1).Copy _ 
Destination:=wb.Sheets("Sheet2").Range("A2" & lastrow).Offset(1, 0)

wb.Sheets("Sheet1").Range("A2:A" & i).Offset(0, 1).Copy _
Destination:=wb.Sheets("Sheet2").Range("A2:A" & i).Offset(1, 0)

Next i

End Sub

CodePudding user response：

With the help of the following function you will find the last non empty row in column 1

Function FindLastRow(rg As Range) As Long
    
    On Error GoTo EH
    
    FindLastRow = rg.Find("*", , Lookat:=xlPart, LookIn:=xlFormulas _
        , searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    Exit Function
    
EH:
    FindLastRow = rg.Cells(1, 1).Row
    
End Function

Then you can copy the data into worksheet 2 with the following code

Sub pasteData()

    Dim wks1 As Worksheet
    Set wks1 = Worksheets("Sheet1")
    
    Dim lastRow As Long
    lastRow = FindLastRow(wks1.Columns(1))     ' last non empty row in column 1
    
    Dim rg As Range
    Set rg = wks1.Range("A1:B" & lastRow)       'range with the data in question
    
    Dim vdat As Variant
    vdat = rg.Value                             ' copy the data into an arry
        
    ' dim array which is big enough for the result
    Dim rDat As Variant
    ReDim rDat(0 To 2 * lastRow)
    
    ' copy the data from the 2-dim array into 1-dim array
    Dim i As Long, j As Long
    For i = LBound(vdat) To UBound(vdat)
        ' copy only data where the first column contains data
        If Len(vdat(i, 1)) > 0 Then
            rDat(j) = vdat(i, 1)
            rDat(j   1) = vdat(i, 2)
            j = j   2
        End If
    Next i
    
    Dim wks2 As Worksheet
    Set wks2 = Worksheets("Sheet2")
    
    ' prepare the second range (bigger than needed but does not harm)
    Set rg = wks2.Range("A1:A" & 2 * lastRow)
    ' copy the data into the second sheet
    rg = WorksheetFunction.Transpose(rDat)

End Sub