如何使用不同的列标题将多个工作表复制到主工作表

Question

我正在尝试创建 vba，通过匹配列标题将多个工作表合并到一个主工作表中。我已经找到了来自微软的多个线程和文档，但我仍然不够。我从其他用户那里获取了很多东西，并添加了我需要的改动。这就是我所拥有的...

    Option Compare Text

    Sub cc()

        Dim Sheet As Worksheet
        Dim DestSheet As Worksheet
        Dim Last As Long
        Dim SheetLast As Long
        Dim CopyRange As Range
        Dim StartRow As Long

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        Set DestSheet = Sheet("Database_Headers")
        StartRow = 2

        For Each Sheet In ActiveWorkbook.Worksheets
            If LCase(Left(Sheet.Name, 6)) = "Demand" Then

                Last = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row
                SheetLast = Sheet.Cells(Rows.Count, "A").End(xlUp).Row

                If SheetLast > 0 And SheetLast >= StartRow Then

                    Sheet.Select
                    Region_Name = WorksheetFunction.Match("Region Name", Rows("1:1"), 0)
                    location_code = WorksheetFunction.Match("location_code", Rows("1:1"), 0)
                    location_name = WorksheetFunction.Match("location_name", Rows("1:1"), 0)
                    dealer_code = WorksheetFunction.Match("dealer_code", Rows("1:1"), 0)

                    Sheet.Columns(Region_Name).Copy Destination:=DestSheet.Range("C" & Last + 1)
                    Sheet.Columns(location_code).Copy Destination:=DestSheet.Range("D" & Last + 1)
                    Sheet.Columns(location_name).Copy Destination:=DestSheet.Range("E" & Last + 1)
                    Sheet.Columns(dealer_code).Copy Destination:=DestSheet.Range("F" & Last + 1)

                End If

            End If

            CopyRange.Copy

            With DestSheet.Cells(Last + 1, "C")
        
            End With

            DestSheet.Cells(Last + 1, "B").Resize(CopyRng.Rows.Count).Value = Sheet.Name

        Next
 
    ExitTheSub:

        Application.Goto DestSh.Cells(1)

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    
    End Sub

我当前的错误来自：

Set DestSheet = Sheet("Database_Headers") 

但我不确定是否需要进一步澄清，或者是否需要添加进一步的澄清行。

提前感谢大家的帮助！

编辑更新

我已将代码更新为： 选项比较文本

子抄送()

Dim Sh As Worksheet
Dim DestSheet As Worksheet
Dim Last As Long
Dim SheetLast As Long
'Dim CopyRange As Range
Dim StartRow As Long

'Disables screen updates so screen does not flicker when code is running
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Clarify the summary tab
Set DestSheet = Worksheets("Database_Headers")

    
    ' Will not copy column headers and will only copy data
    StartRow = 2

        'Will copy all data from each sheet that has a different name then the summary tab
        For Each Sh In ActiveWorkbook.Worksheets
        If LCase(Left(Sh.Name, 6)) = "Demand" Then
    
            Last = DestSheet.Cells(Rows.Count, "B").End(xlUp).Row
            shLast = Sh.Cells(Rows.Count, "A").End(xlUp).Row
    
            If shLast > 0 And shLast >= StartRow Then
    
            `Set CopyRange = Sh.Select`
                Region_Name = WorksheetFunction.Match("Region Name", Rows("1:1"), 0)
                location_code = WorksheetFunction.Match("location_code", Rows("1:1"), 0)
                location_name = WorksheetFunction.Match("location_name", Rows("1:1"), 0)
                dealer_code = WorksheetFunction.Match("dealer_code", Rows("1:1"), 0)
    
                Sh.Columns(Region_Name).Copy Destination:=DestSheet.Range("B" & Last + 1)
                Sh.Columns(location_code).Copy Destination:=DestSheet.Range("C" & Last + 1)
                Sh.Columns(location_name).Copy Destination:=DestSheet.Range("D" & Last + 1)
                Sh.Columns(dealer_code).Copy Destination:=DestSheet.Range("E" & Last + 1)
                
            End If
        
      End If
            
    `CopyRange.Copy`
    
    With DestSheet.Cells(Last + 1, "B")
    End With
            
    DestSheet.Cells(Last + 1, "A").Resize(CopyRange.Rows.Count).Value = Sh.Name
         

Next

ExitTheSub:

Application.Goto DestSheet.Cells(1)

' AutoFit the column width in the summary sheet.
DestSheet.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

结束子

我看到有关复制范围功能的另一个错误。我希望 VBA 逐页进行，并且仅复制与母版中的内容匹配的列标题下的数据。感谢您的帮助！！

Answer 1

您的错误在于您没有正确引用

Sheets

集合。应该这样做：

Set DestSheet = Sheets("Database_Headers")

但是，在这种情况下，您不应该引用

Sheets

集合，而应该引用

Worksheets

集合，因为您已将

DestSheet

声明为

Worksheet

，这样可以避免以后出现一些问题。因此像这样：

Set DestSheet = Worksheets("Database_Headers")

一般来说，这就是

Worsheet

和

Sheet

（以及相应的集合）之间的区别 - 创建一个空 Excel 并添加一个图表工作表作为单独的工作表。然后运行以下代码：

Public Sub TestMe()
    Debug.Print Worksheets.Count
    Debug.Print Sheets.Count
End Sub

它将给出

3

和

4

- 您有 3 个 Excel 工作表和 4 个工作表（图表工作表是一个工作表）。

这里有一个问题，如果正确使用它就可以避免 - VBA 参考工作表与图表表

Answer 2

是的，我加载了你的代码并得到了同样的错误。 那是因为你有

Set DestSheet = Sheet("Database_Headers")

但你应该有

Set DestSheet = Sheets("Database_Headers")

之后，您将不得不处理其他错误，例如

For Each Sheet...

您尚未将“Sheet”定义为变量的地方 （使用“Sheet”以外的其他词，因为这是一个保留词——也许是“sh” 这里有一些代码可以帮助您开始——我没有足够的信息来真正完成它，但您可能会发现它很有帮助

Option Explicit
Sub cc()
Dim sh As Worksheet, destSh As Worksheet
Dim s As String, r As Range, i As Integer, j As Integer

Set destSh = Sheets("Database_Headers")
Set destRange = destSh.Range("A1")
For Each sh In Worksheets
  If LCase(Left(Sheet.Name, 6)) = "Demand" Then
    Set r = sh.Range("A1")
    Set r = Range(r, r.End(xlDown))
    For i = 0 To r.Row.Count
      s = r.Offset(i, 0).Value
      If InStr(s, "desired text") Then
        'transferedData = ...
      End If
    Next i
  End If
  'transfer data to destSh
  destRange.Offset(j, 0) = transferedData
  j = j + 1
Next sh

End Sub