仅当下一行为空时才在一列中打印

Question

我有从文件夹中的文件打印到 Excel 表的第 1、2、3 和 4 列的信息。第 1 列和第 2 列将只包含一个信息单元格，但第 2 列和第 3 列的长度会有所不同，但彼此相等。

我的目标是对 A 列执行类似 if 的操作，如果 B 列中它旁边的单元格被占用，则转到下面的行并循环，否则如果单元格为空，则打印其中第 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
    Dim RowLast As Long

    '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
'(1)
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
            'print file name to Column 1
            Workbooks.Open fileName:=MyFolder & objFile.Name
            Set WB = ActiveWorkbook
'(3)
            'copy HOLDER column from F11 (11, 6) until empty
            LastRow = Cells(Rows.count, 1).End(xlUp).Row
            Range(Cells(11, 6), Cells(LastRow, 6)).Copy
            StartSht.Activate
            'print HOLDER column to column 2 in masterfile in next available row
            Range("B" & Rows.count).End(xlUp).Offset(1).PasteSpecial
            WB.Activate
'(4)
            'copy CUTTING TOOL column from F11 (11, 7) until empty
            LastRow = Cells(Rows.count, 1).End(xlUp).Row
            Range(Cells(11, 7), Cells(LastRow, 7)).Copy
            StartSht.Activate
            'print CUTTING TOOL column to column 3 in masterfile in next available row
            Range("C" & Rows.count).End(xlUp).Offset(1).PasteSpecial
            WB.Activate

'(5)
            'print TDS information
            With WB
                For Each ws In .Worksheets
                        'print the file name to Column 1
                        StartSht.Cells(i + 1, 1) = objFile.Name
                        'print TDS name to Column 4
                        With ws
                            .Range("J1").Copy StartSht.Cells(i + 1, 4)
                        End With
                        i = i + 1

                'move to next file
                Next ws
'(6)
                '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
    ActiveWindow.ScrollRow = 1
'(7)
End Sub

我的最终目标是让我的 excel 表格看起来像这样：（之前和之后）

Answer 1

让我们看看这是否能让你更接近：

'(2)
            'print file name to Column 1
            Set WB = Workbooks.Open fileName:=MyFolder & objFile.Name
            Set ws = WB.ActiveSheet
'(3)
            'copy HOLDER column from F11 (11, 6) until empty
            With ws
                lastRow = GetLastRowInColumn(ws, "A")
                .Range(.Cells(11,6), .Cells(lastRow, 6)).Copy
            End With

    Dim destination
    lastRow = GetLastRowInColumn(startSht, "B")
    Set destination = StartSht.Range("B" &   lastRow).Offset(1)
            'print HOLDER column to column 2 in masterfile in next available row
            destination.PasteSpecial
'(4)

            'ReDefine the destination range to paste into Column C
            lastRow = GetLastRowInColumn(startSht, "C")
            Set destination = StartSht.Range("C" & lastRow).Offset(1)

            With ws
                'copy CUTTING TOOL column from F11 (11, 7) until empty
                LastRow = GetLastRowInColumn(ws, "G")
                'print CUTTING TOOL column to column 3 in masterfile in next available row
                .Range(.Cells(11, 7), .Cells(LastRow, 7)).Copy _
                    Destination:=destination
            End With
'(5)
            With WB
               'print TDS information
                For Each ws In .Worksheets
                        'Determine what is the last row in this sheet, +1 to get the next empty row
                        i = GetLastRowInSheet(ws) +1

                        'print the file name to Column 1
                        StartSht.Cells(i, 1) = objFile.Name
                        'print TDS name to Column 4
                        With ws
                            .Range("J1").Copy StartSht.Cells(i, 4)
                        End With

                'move to next file
                Next ws
'(6)
                'close, do not save any changes to the opened files
                .Close SaveChanges:=False
            End With

重要的是，我们不是简单地将i 加一，而是使用GetLastRowInSheet 函数（如下）将i 重置为最后行工作表 + 1。

i = GetLastRowInSheet(ws) + 1

您需要包含这两个函数，其目的是简化您确定LastRow 的笨拙（和重复）方式。 （借用this awesome answer）

Function GetLastRowInColumn(theWorksheet as Worksheet, col as String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.Count).End(xlUp).Row
    End With
End Function

Function GetLastRowInSheet(theWorksheet as Worksheet)
Dim ret
    With theWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            ret = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            ret = 1
        End If
    End With
    GetLastRowInSheet = ret
End Function