Question

我有这个代码可以很好地循环一个文件夹，打开一个文件，将文件的名称输出到我的主文件的第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

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

End Sub

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＆＃39;对于每个新文件，因为第一行在最后一个文件添加到数据后发生了变化。

此外，使用完整参考是一种更好的做法。而不是使用.Activate使用StartSht.Range("C" & lRow).PasteSpecial，WB也是如此。使用WB还可以确保活动工作表是正确的工作表，完整参考WB.Sheets([]).Range(...。

格式化VBA - 在节之间添加空格

2 个答案: