格式化 VBA - 在部分之间添加空格

Question

我的这段代码运行良好，可以遍历文件夹，打开文件，将文件名打印到我的 Masterfile 的第 1 列（带有代码的文件以及我的所有最终信息将去哪里），将文件中的 2 列（长度不同，因为我使用 End(xlUp) 获取列中存在的所有信息）打印到第 2 列和第 3 列，并打印文件中的单元格 J1 到主文件中的第 4 列。

我的问题：文件只有一个名称，一个 J1 单元格，但第 2 列和第 3 列中有多个条目。我需要将其隔开，以便将名称和 J1 打印在每个新条目的顶部。我附上了照片来解释我的意思。第 2 列和第 3 列应该列在它们对应的文件名旁边（最好在每个新文件之间留一个额外的空格）。

（我对它们进行了颜色编码只是为了表明我的意思） 图 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

Answer 1

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

结束子

Answer 2

您需要使用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(...。