Delete Empty Rows of Table And Optimize Code

I have four worksheets (see sample). The goal is to copy Col A from the first three worksheets to Col A of the fourth worksheet, sort the result and get rid of empty rows. Here is what I have done so far in the code below:

Delete old data from Col A of table on Worksheet 4
Copy Col A of Worksheet 1 to Col A of Worksheet 4
Copy Col A of Worksheet 2 to Col A of Worksheet 4
Copy Col A of Worksheet 3 to Col A of Worksheet 4
Sort Col A of Worksheet 4 to separate data from empty cells

Sub GetData()
    Dim NumRows As Long
    Dim NextRow As Long
    Dim Rw As Long
    Dim ws1 As Worksheet: Set ws1 = Sheets("One")
    Dim ws2 As Worksheet: Set ws2 = Sheets("Two")
    Dim ws3 As Worksheet: Set ws3 = Sheets("Three")
    Dim ws4 As Worksheet: Set ws4 = Sheets("Four")
    Dim rng1 As Range: Set rng1 = ws1.Range("A2", ws1.Cells(Rows.Count, 1).End(xlUp))
    Dim rng2 As Range: Set rng2 = ws2.Range("A2", ws2.Cells(Rows.Count, 1).End(xlUp))
    Dim rng3 As Range: Set rng3 = ws3.Range("A2", ws3.Cells(Rows.Count, 1).End(xlUp))
    Dim rng4 As Range: Set rng4 = ws4.Range("A2", ws4.Cells(Rows.Count, 1).End(xlUp))
'Prepoare receiving worksheet by deleting prior content
    ws4.Activate
    NumRows = ActiveSheet.UsedRange.Rows.Count
    Range("A2:A" & NumRows).ClearContents
    Range("A3:G" & NumRows).Delete
'Copy Column1 of Worksheet One and paste to Column1 of Worksheet Four
    rng1.Copy Destination:=ws4.Range("A2")
'Find out where the pasted data ends
    With ws4
        NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With
'Copy Column1 of Worksheet Two and paste to Column1 of Worksheet Four
    rng2.Copy Destination:=ws4.Range("A" & NextRow)
'Find out where the pasted data ends
    With ws4
        NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With
'Copy Column1 of Worksheet Three and paste to Column1 of Worksheet Four
    rng3.Copy Destination:=ws4.Range("A" & NextRow)
'Sort the worksheet to force empty rows to the bottom of the table
    ActiveWorkbook.Worksheets("Four").ListObjects("tblFour").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Four").ListObjects("tblFour").Sort.SortFields.Add _
        Key:=Range("tblFour[Column1]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Four").ListObjects("tblFour").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'--------------------------------------------------------
'This is where I am stuck.
'I need to delete the empty rows below the pasted data
'--------------------------------------------------------
End Sub

My original idea was to copy the data into an array or variable, sort the data to exclude the empty cells and then paste the data into Worksheet 4 but I am sorely lacking in the proper skills.

Would you kindly look this over and suggest a better way?

Thanks!

Hi GC Excel, berlan and protonLeah,

A hardy THANKS to all three of you for your thoughtful help. I am learning so much I'm gonna be dangerous one day! I have loaded, studied and tried all three solutions. All three do the job for the most part. I will now work with some elements of all three and post my solution for the benefit of all members. In the meantime here is what I found:

GC Excel's post expanded nicely on my effort by doing away with the individual variables and using For-Next to cycle through. The use of an extra worksheet works fine. This procedure needs the addition of code to erase sheet Four before pasting. Easy to fix.

berlan also shortened my procedure nicely, but went way beyond my meager approach by doing the entire copy/paste in just a few lines of code. Very impressive...but then, I am easily impressed. ;-) This code worked perfectly.

protonLeah came up with the solution I think I was looking for by using an array. This code will take a lot more study on my part to understand what is happening but I am guessing that if we clock it, it might be the fastest, which is great because the real workbook has thousands of rows in each sheet. This solution deleted the entire results table along with its formulas but that even I can fix.

My comments may seem like the teacher lecturing students...nothing could be farther from the truth. I have learned so much from the three of you that I will be documenting my discoveries all day!

As I said, I will now attempt to cobble together all the great work into one solution and post it here for all.

Thanks again for the generous gift of your time and energy. I really appreciate it.

Thanks for the feedback, very much appreciated

Hi protonLeah,

I attempted to modify your code to delete only the rows of Sheet Four from Row 3 down but my "fix" caused an error with the last line of code, which I also modified. I fear I have made matters worse. I also need to sort the result.

Help, please! And thank you.

Sub Collimator2()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Four")
    Dim HolderArray As Variant, _
        temp1       As Variant, _
        TabNames    As Variant, _
        TabPicker   As Variant, _
        MaxRow      As Long, _
        LastRow     As Long
        
    TabNames = Array("one", "two", "three")
    ws.UsedRange.Offset(2).EntireRow.Delete
    For Each TabPicker In TabNames
        LastRow = Sheets(TabPicker).UsedRange.Rows.Count
        MaxRow = IIf(LastRow > MaxRow, LastRow, MaxRow)
    Next TabPicker
    
    For LastRow = 0 To 2
        temp1 = Sheets(TabNames(LastRow)).Range("A2:A" & MaxRow).Value
        temp1 = WorksheetFunction.Transpose(temp1)
        HolderArray = HolderArray & Join(temp1, ",")
    Next LastRow
    HolderArray = Split(HolderArray, ",")
    HolderArray = WorksheetFunction.Transpose(HolderArray)
    Sheets("four").Range("A1").Resize(rowsize:=UBound(HolderArray)).Value = HolderArray
    Sheets("four").Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeBlanks).Delete
End Sub