excel 从所有工作表上最后填充的列中获取所有填充的单元格，并粘贴到新工作表的下一个空行中

dnph8jn4 于 2022-11-18 发布在其他

关注(0)|答案(1)|浏览(147)

VBA的新手。尝试从每个工作表中最后填充的列中获取填充的单元格，并将所有这些值粘贴到单个工作表中-在下一个空行上，这样就不会覆盖任何值。有以下内容，但在为LastCol变量分配范围时有问题。欢迎提供指导。

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

excel

来源：https://stackoverflow.com/questions/74354419/get-all-populated-cells-from-last-populated-column-on-all-worksheets-and-paste-i

1条答案

按热度按时间

z0qdvdin1#

提取最后一列

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

赞(0）回复(0）举报 2022-11-18

我来回答

excel 从所有工作表上最后填充的列中获取所有填充的单元格，并粘贴到新工作表的下一个空行中

1条答案

提取最后一列

相关问题

热门标签

最新问答