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工作表看起来像这样：（之前和之后）

Before Image

After Image

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重置为<工作表中的em> last 行+ 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

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

1 个答案: