循环遍历工作表，将数据粘贴到具有匹配名称的列中的另一个工作表中

Question

我想合并多个Excel工作表中的表与不常见和常见的列名。

我无法将循环转到工作簿中的工作表并粘贴到合并工作表中。

例如，我有以下表格：

工作表Sheet1：

  name    surname   color
  Eva       x       
  steven    y       black
  Mark      z       white

Sheet2中：

  Surname  color      name     code
  L         Green     Pim      030 
  O         yellow    Xander   34 
  S                   Rihanna  567

我的第三张纸（合并纸）包含所有纸张的所有可能列名，因此它看起来像：

name    surname   color  code

宏应该读取Sheet1和Sheet2，然后将组合表中的数据粘贴到正确的列名称下。

组合表应如下所示，Sheet2的元素位于Sheet1的元素下：

name    surname   color     code
 Eva       x       
 steven    y       black
 Mark      z       white
 Pim       L       Green   030
 Xander    O       yellow  34
 Rihanna   S               567

我无法读取循环，然后在右列粘贴数据。

Sub CopyDataBlocks_test2()
  'VARIABLE NAME                  'DEFINITION
  Dim SourceSheet As Worksheet    'The data to be copied is here
  Dim CombineSheet As Worksheet   'The data will be copied here
  Dim ColHeaders As Range         'Column headers on Combine sheet
  Dim MyDataHeaders As Range      'Column headers on Source sheet
  Dim DataBlock As Range          'A single column of data
  Dim c As Range                  'a single cell
  Dim Rng As Range                
  'The data will be copied here (="Place holder" for the first data cell)
  Dim i As Integer

  'Dim WS_Count As Integer         'for all sheets in active workbook
  'Dim j As Integer                'Worksheets count

  'Change the names to match your sheetnames:
  Set SourceSheet = Sheets(2)
  Set CombineSheet = Sheets("Combine")

  With CombineSheet
      Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End (xlToLeft))
      Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 
  End With

  With SourceSheet
      Set MyDataHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))

      For Each c In MyDataHeaders
          If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
              MsgBox "Can't find a matching header name for " & c.Value & _
                vbNewLine & "Make sure the column names are the same and try again."
              Exit Sub    
          End If
      Next c

      'A2:A & the last cell with something on it on column A
      Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
      Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)
      For Each c In MyDataHeaders
        i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0)

        'Writes the values
        Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value
      Next c
  End With
End Sub

Answer 1

你只需将你的With SourceSheet - End With块代码包装成一个For each sourceSheet in Worksheets - Next循环，检查不要处理“合并”表单本身

将它移动到辅助程序Sub会更清晰如下：

Option Explicit

Sub CopyDataBlocks_test2()
    'VARIABLE NAME                 'DEFINITION
    Dim sourceSheet As Worksheet    'The data to be copied is here
    Dim ColHeaders As Range         'Column headers on Combine sheet

    With Worksheets("Combine") '<--| data will be copied here
        Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
        For Each sourceSheet In Worksheets '<--| loop through all worksheets
            If sourceSheet.Name <> .Name Then ProcessSheet sourceSheet, ColHeaders, .Cells(.Rows.Count, 1).End(xlUp).Offset(1) '<--| process data if not "Combine" sheet
        Next
    End With
End Sub


Sub ProcessSheet(sht As Worksheet, ColHeaders As Range, rng As Range)
    Dim MyDataHeaders As Range      'Column headers on Source sheet
    Dim c As Range                  'a single cell
    Dim i As Integer
    Dim DataBlock As Range          'A single column of data

    With sht
        Set MyDataHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))

        For Each c In MyDataHeaders
            If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
                MsgBox "In worksheet " & .Name & " can't find a matching header name for " & c.Value & vbNewLine & "Make sure the column names are the same and try again."
                Exit Sub
            End If
        Next c

        Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'A2:A & the last cell with something on it on column A

        For Each c In MyDataHeaders
            i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0)
            rng.Offset(, i - 1).Resize(DataBlock.Rows.Count, 1).Value = DataBlock.Columns(c.Column).Value   'Writes the values
        Next c
    End With
End Sub