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:
谁能告诉我如何为每个项目创建单独的行？显示了我拼凑在一起的代码 - 我认为问题的解决方案在于如何格式化标题为“更改此范围以满足您自己的需求”的部分
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 个字段是从顶部拍摄的，但我think你可以更换你的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