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

第一次由长期用户的海报！ 希望你能帮助填补空白！

我正在尝试创buildvba，通过匹配列标题将多个工作表合并到一个主工作表中。 我已经find了来自微软的多个线程和文档，但是我仍然很短。 我已经从其他用户抓住了很多，并添加了我需要的扭曲。 这是我有…

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

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

提前谢谢大家的帮助！

编辑更新

我已经更新了代码：Option Compare Text

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 

结束小组

我看到关于我的复制范围function的另一个错误。 我想vba去工作表，并且只复制列标题下匹配什么在主人的数据。 谢谢您的帮助！！

Answer 1

您的错误是因为您没有正确引用Sheets集合。 应该这样做：

Set DestSheet = Sheets("Database_Headers")

但是，在这种情况下，您不应该引用Sheets集合，而是引用Worksheets集合，因为您已将DestSheet声明为Worksheet ，因此稍后可以避免出现一些问题。 因此，像这样：

Set DestSheet = Worksheets("Database_Headers")

一般来说，这是Worsheet和Sheet （以及相应的集合）之间的Worsheet – 创build一个空的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”定义为一个variables（使用除“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