【发布时间】：2017-10-12 20:13:14
【问题描述】：
我有数百个电子表格，我想将它们合并到一个主工作表中。每个电子表格包含多个销售的一般描述信息，然后是一个零件列表，其中包含每个零件特定的信息列，如下所示：
在主表中，我希望每个部分都有一个单独的行，其中包括一般信息以及特定部分信息，如下所示：
我创建了一个循环来提取我想要的所有信息，但是所有信息都在主表中写成一行，如下所示：
谁能告诉我如何为每个项目创建一个单独的行？显示了我拼凑的代码-我认为解决我的问题的方法在于如何格式化标题为“更改此范围以适合您自己的需要”的部分
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
【问题讨论】：
-
每次处理源工作表中的新行时，开始写入主工作表中的新行。 （没有看到您的代码，这大概是我能建议的最好的了。）要创建 MCVE，请复制您的代码并删除所有与您的问题无关的行。运行您最终得到的内容，以确保它仍然按照您在问题中说明的方式运行，然后发布该代码。
-
感谢您的评论 - 我已经包含了代码的精简版本。我不确定我的问题可能出在从原始工作表中选择数据的部分（“更改此范围以适合您自己的需要”）或将数据写入新工作表的部分（“复制从源范围到目标范围的值”）。