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")

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

提前感谢大家的帮助!!!

编辑更新

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

Sub cc（）

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

End Sub

我看到了关于我的复制范围功能的另一个错误。我希望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 Refer to worksheet vs chart sheet

Answer 2

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

Set DestSheet = Sheet("Database_Headers")

但你应该

Set DestSheet = Sheets("Database_Headers")

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

For Each 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

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

2 个答案: