帮助合并跨多个选项卡使用的最后一列的代码

Question

我有一系列电子表格，我们使用这些电子表格将参数加载到数据库中，以实现点击式订单输入。一些电子表格有数百张工作表，保持最新状态一直是个问题。我要做的是插入一些代码，这些代码将逐页进行，并将每个选项卡中的一些数据编译到摘要表中。

我已经修改了来自Excel VBA to insert sheet name on each row when combining data tables with variable columns 的代码，但我是个彻头彻尾的黑客，到目前为止还没有成功。

简而言之，我需要代码来返回 A 列中的工作表名称，然后扫描第一行以查找第一个未使用的列，然后将该列的内容返回到 C 列和它来自的行#汇总表上的 B 列。

此示例说明了数据的结构，一系列问题，最后有答案。它们不是静态的，但问题在第 1 行有标题（有时只是一个空格值），但答案没有，该列的单元格 1 始终为空白（null）。

编辑：使用 Stack Overflow 上的多个资源，我设法将它拼凑在一起，几乎可以正常工作。我需要找到带有空标题的第一列（第 1 行）和任何中断之前的最后一行，而不是找到最后使用的列和行。这是因为在数据右侧和可能下方的大多数工作表中添加了注释。

Sub CopyData()
    Application.ScreenUpdating = False
    Dim wsSummary As Worksheet
    Dim LastRowWs As Long
    Dim LastColWs As Long
    Dim LastRowSummary As Long
    Dim StartRowSummary As Long
    Set wsSummary = ThisWorkbook.Worksheets("Summary") ' defines WsSummary
    LastRowSummary = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row + 1 ' identifys the last used row on target summary sheet
    wsSummary.Range("A2:ZZ" & LastRowSummary).Clear 'clears a set range on target summary sheet
    For Each Ws In ThisWorkbook.Worksheets
        Select Case Ws.Name
            Case "Summary", "Category", "TOC", "Index"
                'If it's one of these sheets, do nothing
            Case Else
            LastRowWs = Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row ' Finds the last column in worksheet
            LastColWs = Ws.Cells(LastRowWs, Columns.Count).End(xlToLeft).Column ' Finds the last used colun in Worksheet - ISSUE, I need first null cell column!
            StartRowSummary = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row + 1 'first empty row
            Ws.Range(Split(Cells(, LastColWs).Address, "$")(1) & "2:" & Split(Cells(, LastColWs).Address, "$")(1) & LastRowWs).Copy Destination:=wsSummary.Range("A" & StartRowSummary)
            LastRowSummary = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row
            wsSummary.Range("B" & StartRowSummary & ":B" & LastRowSummary) = Ws.Name ' returns sheet name
            wsSummary.Range("C" & StartRowSummary & ":C" & LastRowSummary) = LastColWs 'returns column #
            wsSummary.Range("D" & StartRowSummary & ":D" & LastRowSummary) = Split(Cells(, LastColWs).Address, "$")(1) 'returns Column letter
        End Select
    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

试试这个 - 稍微拆分一下逻辑，让它更容易理解......

Sub CopyData()
    
    Dim wsSummary As Worksheet
    Dim LastRowWs As Long
    Dim LastColWs As Long
    Dim LastRowSummary As Long
    Dim StartRowSummary As Long, copyRange As Range, nextRow As Long
    Dim copyRows As Long, colLetter, ws As Worksheet
    
    Application.ScreenUpdating = False
    
    Set wsSummary = ThisWorkbook.Worksheets("Summary") ' defines WsSummary
    LastRowSummary = wsSummary.Cells(wsSummary.Rows.Count, "A").End(xlUp).Row + 1
    wsSummary.Range("A2:ZZ" & LastRowSummary).Clear 'clears a set range on target summary sheet
    
    nextRow = 2                              'start pasting here
    For Each ws In ThisWorkbook.Worksheets
        If ProcessThisSheet(ws) Then         'use this sheet ?
            Set copyRange = GetCopyRange(ws) 'find something to copy
            If Not copyRange Is Nothing Then
                copyRows = copyRange.Cells.Count
                colLetter = Split(copyRange.EntireColumn.Address(0, 0), ":")(0)
                With wsSummary.Rows(nextRow)
                    copyRange.Copy .Cells("A")
                    .Columns("B").Resize(copyRows).Value = ws.Name
                    .Columns("C").Resize(copyRows).Value = copyRange.Column
                    .Columns("C").Resize(copyRows).Value = colLetter
                End With
                nextRow = nextRow + copyRows
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

'find the range of cells to copy from (returns Nothing if no suitable range located)
Function GetCopyRange(ws As Worksheet) As Range
    Dim c As Range, c2 As Range, rv As Range
    Set c = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Offset(1, 1) 'cell below the empty header cell
    If c.Column = 2 Or Len(c.Value) = 0 Then Exit Function 'on Col2 so row1 was empty, or no value below the empty header
    If Len(c.Offset(1, 0).Value) > 0 Then
        Set GetCopyRange = ws.Range(c, c.End(xlDown)) 'down to end of data
    Else
        Set GetCopyRange = c 'just 1 cell to copy
    End If
End Function

'work with `ws` ?
Function ProcessThisSheet(ws As Worksheet)
    Select Case ws.Name
        Case "Summary", "Category", "TOC", "Index"
            ProcessThisSheet = False
        Case Else
            ProcessThisSheet = True
    End Select
End Function

Answer 2

您是否考虑过制作表格、表格并将它们关联起来？

如果您正在组合具有 ID 关系的数据，即使它们跨越数千张工作表，您也可以使用“插入”选项卡将它们设置为带有正确标题的表，在“数据”选项卡中关联它们，然后在 Power Pivot/Query 中将它们组合在一起，一旦完成，您就可以在 Power Query 上执行获取最后一行的操作，然后您无需编写任何代码，或者一个更好的链接到该 Power Pivoted Table 作为表实例，并让您的系统获取最后一行或多行（只需更改号码）。

  SELECT TOP 1 FROM tblResult ORDER BY ID DESC