如何根据Excel工作表中的标题复制信息？

我正在审查以下代码：

Sub Combine() Dim J As Integer On Error Resume Next Sheets(1).Select Worksheets.Add Sheets(1).Name = "Combined" Sheets(2).Activate Range("A1").EntireRow.Select Selection.Copy Destination:=Sheets(1).Range("A1") For J = 2 To Sheets.Count Sheets(J).Activate Range("A1").Select Selection.CurrentRegion.Select Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2) Next End Sub 

此代码组合单元格进行报告。 这应该是从所有表单中复制信息到一个组合表单。 但是，如果我有不同的标题，即如果在Sheet1!A1是“地址”，并在Sheet2!A1是“名称”，它将复制地址下的名称。

有没有办法进行某种search，以便它只会复制确切的标题并将其粘贴到正确的标题下？

Answer 1

这是一个例子…

 Option Explicit Sub CombineData() '--combines data from all sheets ' assumes all sheets have exact same header fields as the ' first sheet; however the fields may be different order. '--combines using copy-paste. could be modified to pasteValues only Dim lNdxSheet As Long, lNextRow As Long, lDestCol As Long Dim lColCount As Long, lRowCount As Long Dim rHeaders As Range Dim sHeader As String Dim vMatch As Variant, vHeaders As Variant Dim wksCombined As Worksheet With Application .ScreenUpdating = False .DisplayAlerts = False End With '--add new sheet for results Set wksCombined = Worksheets.Add(Before:=Worksheets(1)) '--optional: delete existing sheet "Combined" On Error Resume Next Sheets("Combined").Delete On Error GoTo 0 With wksCombined .Name = "Combined" '--copy headers that will be used in destination sheet Set rHeaders = Sheets(2).Range("A1").CurrentRegion.Resize(1) rHeaders.Copy Destination:=.Range("A1") End With '--read headers into array vHeaders = rHeaders.Value lColCount = UBound(vHeaders, 2) lNextRow = 2 For lNdxSheet = 2 To Sheets.Count '--count databody rows of continguous dataset at A1 lRowCount = Sheets(lNdxSheet).Range("A1").CurrentRegion.Rows.Count - 1 If lRowCount > 0 Then For lDestCol = 1 To lColCount sHeader = vHeaders(1, lDestCol) '--search entire first col in case field is rSourceData vMatch = Application.Match(sHeader, Sheets(lNdxSheet).Range("1:1"), 0) If IsError(vMatch) Then MsgBox "Header: """ & sHeader & """ not found on sheet: """ _ & Sheets(lNdxSheet).Name GoTo ExitProc End If With Sheets(lNdxSheet) '--copy-paste this field under matching field in combined .Cells(2, CLng(vMatch)).Resize(lRowCount).Copy ' Option 1: paste values only wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteValues) ' Option 2: paste all including formats and formulas ' wksCombined.Cells(lNextRow, lDestCol).PasteSpecial (xlPasteAll) End With Next lDestCol lNextRow = lNextRow + lRowCount End If ' lRowCount > 0 Next lNdxSheet ExitProc: With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub