Get all populated cells from last populated column on all worksheets and paste into a new sheet in n-CodePudding

Fairly new to VBA. Trying to get the populated cells from the last populated column in each worksheet and paste all these values into a single worksheet - on next empty row so no values are overwritten. Have the following but something is wrong with assigning a range to the LastCol variable. Any guidance appreciated.


Sub ExtractLastColumn()

Dim ws As Worksheet
Dim sht As Worksheet
Dim wrk As Workbook
Dim LastCol As Range
Dim LastRow As Range

'Create new sheet and combine tabs

Set wrk = ActiveWorkbook 'Working in active workbook

 'Add new worksheet as the last worksheet called INSERTS
 
    With ThisWorkbook
        Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        ws.Name = "INSERTS"
    End With


 'loop to get values from last column on each worksheets and paste into new INSERTS sheet
For Each sht In wrk.Worksheets
If sht.Name <> "INSERTS" And sht.Name <> ws.Name Then

    'get range of populated cells in last populated column
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Value
    
   'get next empty row on INSERTS sheet
    Worksheets("INSERTS").Activate
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row   1

     'paste range from sheet into next emtpy row for INSERTS sheet
     Worksheets(sht).Range(LastCol).Copy Worksheets("INSERTS").Range(LastRow)

End If
Next sht

End Sub

CodePudding user response：

Extract Last Column

Sub ExtractLastColumn()

    ' Define constants.
    Const DESTINATION_WORKSHEET_NAME As String = "INSERTS"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A2"

    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Application.ScreenUpdating = False
    
    ' Delete the destination sheet if it exists.
    
    Dim dsh As Object
    Dim dCodeName As String
    
    On Error Resume Next
        Set dsh = wb.Sheets(DESTINATION_WORKSHEET_NAME)
    On Error GoTo 0
    If Not dsh Is Nothing Then
        If TypeOf dsh Is Worksheet Then dCodeName = dsh.CodeName
        Application.DisplayAlerts = False
            dsh.Delete
        Application.DisplayAlerts = True
    End If
    
    ' Write all worksheet names to an array.
    
    Dim wsCount As Long: wsCount = wb.Worksheets.Count
    Dim WorksheetNames() As String: ReDim WorksheetNames(1 To wsCount)
    
    Dim sws As Worksheet
    Dim n As Long
    
    For Each sws In wb.Worksheets
        n = n   1
        WorksheetNames(n) = sws.Name
    Next sws
    
    ' Add a new worksheet, the destination worksheet.
    
    Dim dws As Worksheet
    Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    dws.Name = DESTINATION_WORKSHEET_NAME
    If Len(dCodeName) > 0 Then
        wb.VBProject.VBComponents(dws.CodeName).Name = dCodeName
    End If
    
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    ' Copy the last column from each source worksheet
    ' to the destination worksheet.
    
    Dim srg As Range
    
    For Each sws In wb.Worksheets(WorksheetNames)
        With sws.UsedRange
            Set srg = .Columns(.Columns.Count)
        End With
        srg.Copy dfCell
        Set dfCell = dfCell.Offset(srg.Rows.Count)
    Next sws
    
    Application.ScreenUpdating = True

    ' Inform.

    MsgBox "Last columns extracted.", vbInformation

End Sub