合并多个工作簿时，为每个项目创建单独的行 [英] Create separate row for each item when merging multiple workbooks

问题描述

我有数百个电子表格，我想将它们合并到一个母版纸中.每个电子表格都包含多个销售中的一般描述信息，然后是零件列表以及每个零件特有的信息列，如下所示:

I have several hundred spreadsheets that I would like to combine into a single master sheet. Each spreadsheet contains general description information in several sells, and then a list of parts with columns of information that are specific to each part, as shown:

在主表中，我希望每个零件都有单独的一行，其中包括常规信息和特定零件信息，如下所示:

In the master sheet, I want a separate line for each part that includes the general information as well as the specific part information, as shown:

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

I have created a loop that pulls all the information I want, but all the information is written as a single line in the master sheet, as shown:

有人可以告诉我如何为每个项目创建单独的行吗?显示了我拼凑的代码-我认为解决问题的方法在于如何格式化标题为更改此范围以适合您自己的需求"的部分

Can anyone tell me how to create a separate line for each item? The code I have pieced together is shown- I think the solution to my problem lies in how to format the section titled "change this range to fit your own needs"

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

推荐答案

我有点担心，因为您似乎要写入母版表的标题似乎与数据不一致，并且您似乎仅从每张纸的顶部复制Range("A11, A5, B5")，但是您的图像显示从顶部开始拍摄的5个字段，但是我认为，您可以将For FNum循环替换为以下内容:

I'm slightly worried because the headings you seem to be writing to the master sheet don't seem to line up with the data, and because you seem to be only copying Range("A11, A5, B5") from the top part of each sheet but your images show 5 fields being taken from the top, but I think you can replace your For FNum loop with the following:

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

这篇关于合并多个工作簿时，为每个项目创建单独的行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！