格式化VBA – 在部分之间添加空格
我有这个代码运行良好，循环通过一个文件夹，打开一个文件，将文件的名称打印到我的主文件 （ 该文件的代码和所有我的最终信息将去 ）列1，打印2列（ 因为我使用End（xlUp）获取列中存在的所有信息 ）从列表2到列3中，并将单元格J1从文件打印到主文件中的列4。
我的问题：只有一个文件的名称，一个J1单元格，但第2列和第3列中有多个条目。我需要将其分隔出来，以便名称和J1打印在每个新条目的顶部。 我附上照片来解释我的意思。 第2列和第3列应该在相应的文件名旁边列出（最好在每个新文件之间有一个额外的空格）。
（ 我用颜色编码，只是为了显示我的意思 ）图片1：它看起来如何（所有的信息都只是倾倒在每一列中）图片2：我想如何看它（文件名是如此水平分布的，所有的信息对应于相同的文件）
输出这些数据的代码也在下面。 非常感谢您给我的任何帮助/指导！
图片1： 
图2：
Option Explicit Sub LoopThroughDirectory() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim MyFolder As String Dim StartSht As Worksheet, ws As Worksheet Dim WB As Workbook Dim i As Integer Dim LastRow As Integer, erow As Integer Dim Height As Integer 'turn screen updating off - makes program faster 'Application.ScreenUpdating = False 'location of the folder in which the desired TDS files are MyFolder = "C:\Users\trembos\Documents\TDS\progress\" 'Set StartSht = ActiveSheet Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1") 'create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'get the folder object Set objFolder = objFSO.GetFolder(MyFolder) i = 1 'loop through directory file and print names For Each objFile In objFolder.Files If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then 'print file name to Column 1 Workbooks.Open fileName:=MyFolder & objFile.Name Set WB = ActiveWorkbook 'print "HOLDER" column 'Range("HOLDER").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=WB.Range(Rows.count, 6).End(xlUp).Row, CopyToRange:=StartSht.Range(Rows.count, 2).End(xlUp).Row, Unique:=False 'WB.Range("F10:F25").Value = StartSht.Range("C2:C17").Value ' For i = 1 To 20 ' ActiveSheet.Range("F10:F25") = StartSht("Sheet1").Range("C2:C17") ' Next i ' Range(Rows.count, 6).End(xlUp).Row.Copy ' StartSht.Activate ' Range(Rows.count, 2).End(xlUp).Row.Select ' ActiveSheet.Paste ' ' WB.Activate LastRow = Cells(Rows.count, 1).End(xlUp).Row Range(Cells(11, 6), Cells(LastRow, 6)).Copy StartSht.Activate Range("B" & Rows.count).End(xlUp).Offset(1).PasteSpecial WB.Activate LastRow = Cells(Rows.count, 1).End(xlUp).Row Range(Cells(11, 7), Cells(LastRow, 7)).Copy StartSht.Activate Range("C" & Rows.count).End(xlUp).Offset(1).PasteSpecial WB.Activate 'print TOOLING DATA SHEET(TDS): values to Column 2 With WB For Each ws In .Worksheets StartSht.Cells(i + 1, 1) = objFile.Name With ws .Range("J1").Copy StartSht.Cells(i + 1, 4) End With i = i + 1 'move to next file Next ws 'close, do not save any changes to the opened files .Close SaveChanges:=False End With End If 'move to next file Next objFile 'turn screen updating back on 'Application.ScreenUpdating = True End Sub Option Explicit Sub LoopThroughDirectory() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim MyFolder As String Dim StartSht As Worksheet, ws As Worksheet Dim WB As Workbook Dim i As Integer Dim LastRow As Integer, erow As Integer Dim Height As Integer 'turn screen updating off - makes program faster 'Application.ScreenUpdating = False 'location of the folder in which the desired TDS files are MyFolder = "C:\Users\trembos\Documents\TDS\progress\" 'Set StartSht = ActiveSheet Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1") 'create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'get the folder object Set objFolder = objFSO.GetFolder(MyFolder) i = 1 'loop through directory file and print names For Each objFile In objFolder.Files If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then 'print file name to Column 1 Workbooks.Open fileName:=MyFolder & objFile.Name Set WB = ActiveWorkbook LastRow = Cells(Rows.count, 1).End(xlUp).Row Range(Cells(11, 6), Cells(LastRow, 6)).Copy StartSht.Activate nextRow = Range("B" & Rows.count).End(xlUp) + 1 Range("B" & nextRow).PasteSpecial WB.Activate LastRow = Cells(Rows.count, 1).End(xlUp).Row Range(Cells(11, 7), Cells(LastRow, 7)).Copy StartSht.Activate Range("C" & nextRow).PasteSpecial WB.Activate 'print TOOLING DATA SHEET(TDS): values to Column 2 With WB For Each ws In .Worksheets StartSht.Cells(nextRow, 1) = objFile.Name With ws .Range("J1").Copy StartSht.Cells(nextRow, 4) End With i = i + 1 'move to next file Next ws 'close, do not save any changes to the opened files .Close SaveChanges:=False End With End If 'move to next file Next objFile 'turn screen updating back on 'Application.ScreenUpdating = True
结束小组
您需要使用Range("B" & Rows.count).End(xlUp).Row + 2作为所有列的第一行，因为它是所有数据的最后一行，对于一个空格是+2行。
你的粘贴语句应该如下所示：
Dim lRow as Long ... lRow = StartSht.Range("B" & Rows.count).End(xlUp).Row + 2 ... StartSht.Range("B" & lRow).PasteSpecial ... StartSht.Range("C" & lRow).PasteSpecial ... i = lRow ... StartSht.Cells(i, 1) = objFile.Name ... .Range("J1").Copy StartSht.Cells(i, 4) i = i + 1
另外 ：计算每个新文件的“lRow”，因为在最后一个文件被添加到数据之后，第一行改变。
另外，使用完整的参考文件是一个更好的做法。 而不是使用.Activate使用StartSht.Range("C" & lRow).PasteSpecial ， WB 。 使用WB也要确保活动页是正确的，完整的参考WB.Sheets([]).Range(...