Question

我有几百个电子表格，我想将它们组合成一个主表格。每个电子表格包含多个销售中的一般描述信息，然后是包含特定于每个部分的信息列的部分列表，如下所示：

在主表中，我想为每个部分分别包含一般信息以及特定部件信息，如下所示：

我创建了一个循环来提取我想要的所有信息，但是所有信息都在主表中作为单行写入，如下所示：

有谁能告诉我如何为每个项目创建单独的行？显示了我拼凑在一起的代码 - 我认为我的问题的解决方案在于如何格式化标题为“更改此范围以满足您自己的需求”的部分

Sub MergeNT154BatchCards()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet

Dim dt As String
Dim bookName As String

Dim rnum As Long, CalcMode As Long
Dim a As Range, c As Range
Dim x As Long

Dim sourceRange As Range, destrange As Range

' Change this to the path\folder location of your files.
MyPath = "C:\Users\amiller\OneDrive - CoorsTek\temp"

' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
End If

' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xls*")
If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
End If

' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
    FNum = FNum + 1
    ReDim Preserve MyFiles(1 To FNum)
    MyFiles(FNum) = FilesInPath
    FilesInPath = Dir()
Loop

' Set various application properties.
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    ActiveSheet.Name = "Density"
    bookName = "DensitySummary"
    dt = Format(CStr(Now), "yyyy_mm_dd_hh.mm")
    BaseWks.SaveAs Filename:="C:\Users\amiller\OneDrive - CoorsTek\temp\" & bookName & dt
rnum = 1

Range("A1").Value = "FileName"
Range("B1").Value = "Description"
Range("C1").Value = "WaterTemp(C)"
Range("D1").Value = "WaterDensity(g/cc)"
Range("E1").Value = "PartID"
Range("F1").Value = "DryMass(g)"
Range("G1").Value = "SuspendedMass(g)"
Range("H1").Value = "Density(g/cc)"

' Loop through all files in the myFiles array.
If FNum > 0 Then
    For FNum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
        On Error GoTo 0

        If Not mybook Is Nothing Then
            On Error Resume Next

            ' Change this range to fit your own needs.
            With mybook.Worksheets(1)
                Set R1 = Range("A11, A5, B5")
                Set R2 = Range("A13:D" & Range("A13").End(xlDown).Row)
                Set RF = Union(R1, R2)
                Set sourceRange = RF

            End With

            If Err.Number > 0 Then
                Err.Clear
                Set sourceRange = Nothing
            Else

                ' If source range uses all columns then
                ' skip this file.
                If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                    Set sourceRange = Nothing
                End If
            End If
            On Error GoTo 0

            If Not sourceRange Is Nothing Then

                SourceRcount = sourceRange.Rows.Count

                If rnum + SourceRcount >= BaseWks.Rows.Count Then
                    MsgBox "There are not enough rows in the target worksheet."
                    BaseWks.Columns.AutoFit
                    mybook.Close savechanges:=False
                    GoTo ExitTheSub
                Else

                    ' Copy the file name in column A.
                    With sourceRange
                        BaseWks.Cells(rnum + 1, "A"). _
                                Resize(.Rows.Count).Value = MyFiles(FNum)
                    End With

                    ' Set the destination range.
                    Set destrange = BaseWks.Range("B" & rnum + 1)

                    x = 0
                    For Each a In sourceRange.Areas
                        For Each c In a.Cells
                            x = x + 1
                            destrange.Offset(0, x - 1).Value = c.Value
                        Next c
                    Next a

                    ' Copy the values from the source range
                    ' to the destination range.
                    With sourceRange
                        Set destrange = destrange. _
                                        Resize(.Rows.Count, .Columns.Count)
                    End With
                    destrange.Value = sourceRange.Value

                    rnum = rnum + SourceRcount
                End If
            End If
            mybook.Close savechanges:=False
        End If

    Next FNum
    BaseWks.Columns.AutoFit
End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Answer 1

我有点担心，因为你似乎写在主表上的标题似乎与数据不一致，而且因为你似乎只是在复制Range("A11, A5, B5")每张纸的顶部但您的图片显示从顶部拍摄的5个字段，但我认为您可以使用以下内容替换For FNum循环：

For FNum = LBound(MyFiles) To UBound(MyFiles)
    Set mybook = Nothing
    On Error Resume Next
    Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
    On Error GoTo 0

    If Not mybook Is Nothing Then
        With mybook.Worksheets(1)
            Set SourceRange = .Range("A13:D" & .Range("A13").End(xlDown).Row)

            SourceRcount = SourceRange.Rows.Count

            If rnum + SourceRcount >= BaseWks.Rows.Count Then
                MsgBox "There are not enough rows in the target worksheet."
                BaseWks.Columns.AutoFit
                mybook.Close savechanges:=False
                GoTo ExitTheSub
            Else

                ' Copy the file name in column A.
                BaseWks.Cells(rnum + 1, "A").Resize(SourceRcount).Value = MyFiles(FNum)
                ' Copy information such as date/time started, start/final temp, and Batch ID
                BaseWks.Cells(rnum + 1, "B").Resize(SourceRcount).Value = .Range("A4").Value
                BaseWks.Cells(rnum + 1, "C").Resize(SourceRcount).Value = .Range("B4").Value
                BaseWks.Cells(rnum + 1, "D").Resize(SourceRcount).Value = .Range("A5").Value
                BaseWks.Cells(rnum + 1, "E").Resize(SourceRcount).Value = .Range("A5").Value
                BaseWks.Cells(rnum + 1, "F").Resize(SourceRcount).Value = .Range("A11").Value
                'Copy main data
                BaseWks.Cells(rnum + 1, "G").Resize(SourceRcount, SourceRange.Columns.Count).Value = SourceRange.Value

                rnum = rnum + SourceRcount
            End If
        End With
    End If
    mybook.Close savechanges:=False
Next FNum

Answer 2

问题的根源在于你试图在一个子程序中做太多。每当子程序超过25-40行时，您应该考虑将功能提取到较小的子程序中。通过这种方式，您将能够一次测试较小部分的代码。

通过实施这个策略，我设法将OP原始子程序从152行代码减少到5个易于调试的子程序，包含80行代码。

MergeNT154BatchCards - 主子程序
AddBatchCard - 打开工作簿并将新行数据添加到范围
getDensityTemplate - 基于模板创建新工作簿
getFileList - 从目录
ToggleEvents - 关闭和打开事件并返回当前的计算模式

我还没有对代码的某些部分进行测试，因为@ YowE3K表示标题不排成一行。我认为使用这些较小的代码块修改代码以适应OP要求是相当容易的。

Public Sub MergeNT154BatchCards()
    Dim vFiles As Variant, FileFullName As Variant
    Dim NextRow As Range, wb As Workbook
    Dim CalculationMode As XlCalculation
    CalculationMode = ToggleEvents(False, xlCalculationManual)

    vFiles = getFileList("C:\Users\best buy\Downloads\stackoverfow", "*.xls*")
    If UBound(vFiles) = -1 Then
        MsgBox "No files found", vbInformation, ""
        Exit Sub
    End If

    Set wb = getDensityTemplate

    For Each FileFullName In vFiles
        With wb.Worksheets(1)
            'Add Header
            .Range("A1:H1").Value = Array("FileName", "Description", "WaterTemp(C)", "WaterDensity(g/cc)", "PartID", "DryMass(g)", "SuspendedMass(g)", "Density(g/cc)")
            'Target the next empty row
            Set NextRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
            AddBatchCard CStr(FileFullName), NextRow
        End With
    Next

    ToggleEvents True, CalculationMode
End Sub

Private Sub AddBatchCard(FileFullName As String, NextRow As Range)
    Dim cell As Range
    Dim x As Long, y As Long
    With Workbooks.Open(FileFullName)
        With .Worksheets(1)
            For Each cell In .Range("A13", .Range("A" & .Rows.Count).End(xlUp)).Value
                'NextRow
                NextRow.Cells(1, 1).Value = .Range("A4").Value
                NextRow.Cells(1, 2).Value = .Range("B4").Value
                NextRow.Cells(1, 3).Value = .Range("A5").Value
                NextRow.Cells(1, 4).Value = .Range("B5").Value
                NextRow.Cells(1, 4).Resize(1, 4).Value = cell.Resize(1, 4).Value
                Set NextRow = NextRow.Offset(1)
            Next
        End With
        .Close SaveChanges:=False
    End With
End Sub

Private Function getDensityTemplate(FilePath As String) As Workbook
    Dim SheetsInNewWorkbook As Integer
    Dim wb As Workbook
    SheetsInNewWorkbook = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1

    Set wb = Workbooks.Add(xlWBATWorksheet)
    wb.Worksheets(1).Name = "Density"
    wb.SaveAs FileName:=FilePath & "DensitySummary" & Format(Now, "yyyy_mm_dd_hh.mm")
    Set getDensityTemplate = wb
End Function

Private Function getFileList(FilePath As String, PatternSearch As String) As Variant
    Dim FileName As String
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    With CreateObject("System.Collections.ArrayList")
        FileName = Dir(FilePath & PatternSearch)
        Do While FileName <> ""
            .Add FilePath & FileName
            FileName = Dir()
        Loop
        getFileList = .ToArray
    End With
End Function

Private Function ToggleEvents(EnabelEvents As Boolean, CalculationMode As XlCalculation) As XlCalculation
    With Application
        ToggleEvents = .Calculation
        .Calculation = CalculationMode
        .ScreenUpdating = EnabelEvents
        .EnableEvents = EnabelEvents
    End With
End Function

合并多个工作簿时，为每个项创建单独的行

2 个答案: