Question

我试图使用来自多个不同的数据，使用相同的布局来构建新表。我找到并使用了一个占据50％路径的宏。但现在我卡住了。

目前，我正在使用三个循环检查文件以查找我要复制的信息，并将数据复制到新行上。
现在的结果：
第1行第X列：值A
第2行第X列：值B
第3行第X列：值C

其中X与源文件中表示的数据相同。

目标格式
第1行列A：值A
第1行第B栏：价值B
第1行第C列：值C

这是我的代码：

Sub RetrieveDataToThisWB(wb As String)
Dim ActiveWB As Workbook
Dim Rng As Range, ExtractRng As Range, c As Range
Dim DatRow As Long

Set ActiveWB = Workbooks.Open(Filename:=wb, UpdateLinks:=False, ReadOnly:=True)


With ActiveWB.Sheets(2)
    Set Rng = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, 26))
    Set ExtractRng = FindAll(Rng, "*Value A*")

If Not ExtractRng Is Nothing Then
    For Each c In ExtractRng

        If c.Row > DatRow Then
            ExportRow = ExportRow + 1

            Sheet1.Range(Sheet1.Cells(ExportRow, 1), Sheet1.Cells(ExportRow, 25)).Value = _
                .Range(.Cells(c.Row, 1), .Cells(c.Row, 25)).Value
            Sheet1.Cells(ExportRow, 27).Value = ActiveWB.Name
            Sheet1.Cells(ExportRow, 28).Value = ActiveWB.FullName
            Sheet1.Cells(ExportRow, 29).Value = Now()
            DatRow = c.Row
        End If
    Next c
End If
End With
With ActiveWB.Sheets(2)
    Set Rng = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, 26))
    Set ExtractRng = FindAll(Rng, "*Value B*")

If Not ExtractRng Is Nothing Then
    For Each c In ExtractRng

        If c.Row > DatRow Then
            ExportRow = ExportRow + 1

            Sheet1.Range(Sheet1.Cells(ExportRow, 1), Sheet1.Cells(ExportRow, 25)).Value = _
                .Range(.Cells(c.Row, 1), .Cells(c.Row, 25)).Value
            Sheet1.Cells(ExportRow, 27).Value = ActiveWB.Name
            Sheet1.Cells(ExportRow, 28).Value = ActiveWB.FullName
            Sheet1.Cells(ExportRow, 29).Value = Now()
            DatRow = c.Row
        End If
    Next c
End If
End With
With ActiveWB.Sheets(2)
    Set Rng = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, 26))
    Set ExtractRng = FindAll(Rng, "*Value C*")

If Not ExtractRng Is Nothing Then
    For Each c In ExtractRng

        If c.Row > DatRow Then
            ExportRow = ExportRow + 1

            Sheet1.Range(Sheet1.Cells(ExportRow, 1), Sheet1.Cells(ExportRow, 25)).Value = _
                .Range(.Cells(c.Row, 1), .Cells(c.Row, 25)).Value
            Sheet1.Cells(ExportRow, 27).Value = ActiveWB.Name
            Sheet1.Cells(ExportRow, 28).Value = ActiveWB.FullName
            Sheet1.Cells(ExportRow, 29).Value = Now()
            DatRow = c.Row
        End If
    Next c
End If
End With

使用来自多个文件的数据编译一个工作表

0 个答案: