Question

我需要快速帮助才能找到我的错误。

下面的代码应循环显示工作表并将数据复制到相应的列。但它只从1张复印件我试过重置varaiables，但没有任何帮助..

我有类似的宏，其中每个循环和相同的If语句都可以解决问题。

更新

看来问题出在这里无论我写什么样的外循环跳转到下一行它都不跳，它只是一直覆盖单元格。

For Each c In MyDataHeaders 
i = Application.WorksheetFunction.Match(c.value, ColHeaders, 0) 'Finds the 
matching column name Rng.Offset(, i - 1).value = Intersect(DataBlock.EntireRow, 
c.EntireColumn).value 'Writes the values 
Stop 
Next c

以下代码：

 Sub CopyDataBlocks()

 Dim sht As Worksheet
 Dim SourceSheet As Worksheet    'The data to be copied is here
 Dim TargetSheet As Worksheet    'The data will be copied here
 Dim ColHeaders As Range         'Column headers on Target 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

 'Change the names to match your sheetnames:
'Set SourceSheet = Sheets("ws1")
Set TargetSheet = Sheets("Master")

With TargetSheet
Set ColHeaders = .Rows(1) '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft) 'Or just .Range("A1:C1")
Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down

End With

For Each SourceSheet In ThisWorkbook.Worksheets
If SourceSheet.name Like "Sheet*" Then

With SourceSheet
Set MyDataHeaders = Intersect(.Rows(1), .UsedRange)


 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

'There was a match for each colum name.
'Set the first datablock to be copied:
    Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'A2:A & the last cell with something on it on column A

'Resizes the target Rng to match the size of the datablock:
Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)

'Copies the data one column at a time:
For Each c In MyDataHeaders
    i = Application.WorksheetFunction.Match(c.value, ColHeaders, 0) 'Finds the matching column name
    Rng.Offset(, i - 1).value = Intersect(DataBlock.EntireRow, c.EntireColumn).value    'Writes the values
Next c

End With

Set MyDataHeaders = Nothing
End If
Next SourceSheet

End Sub

谢谢！

For Each不会循环显示工作表（没有错误）

0 个答案: