我不能得到我的macros合并表循环？
我已经做了一个macros，用于从多个excel表中合并非罕见和常用列名的表。 但是我无法得到这个循环，这个循环将会放到我活动的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
那么macros必须读取铝板（sheet1和2），并且必须在正确的列名称下将它设置在组合板中。 所以合并单看起来像：
name surname color code Eva x steven y black Mark white Pim L 030 Xander O 34 Rihanna S 567
我的macros在我的问题是，无法得到我的macros读取每个工作表中的循环，然后将其粘贴在正确的kolomn。 例如，如果macros已粘贴sheet1的元素，那么它必须将sheet2的元素粘贴到sheet1的元素下，因此必须将其粘贴到完整的空行中。 我的代码如下：
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 Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'A2:A & the last cell with something on it on column A Set Rng = Rng.Resize(DataBlock.Rows.Count, 1) For Each c In MyDataHeaders i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0) Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value 'Writes the values Next c End With End Sub
你只需要将你的With SourceSheet - End With block代码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