Question

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

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

例如，我有以下表格：

Sheet 1中：

  name    surname   color
  Eva       x       
  steven    y       black
  Mark      z       white

Sheet 2中：

  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循环中，检查不要处理＆＃34;合并＆＃34;表单本身

将其移动到辅助器中会更加清洁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

循环浏览工作表，将数据粘贴到另一个工作表中的列名为

1 个答案: