Question

我从另一篇类似的文章中修改的代码，将第3行复制到最后一行，其中包含来自文件夹中所有工作簿的'Sheet1'中的数据，并放入'SH Dealing yyyy.xlsx''DealSlips'工作表中（添加向下扫过文件夹中的工作簿）。但是，它仅复制在A列中有数据的最后一行。例如，在最后一行中，可能仅在J列或Z列中就有数据，而看不到这些数据并且不将其复制？我是编码的新手，几乎已经猜了几个小时了，代码中需要更改什么！任何帮助表示赞赏。

    Sub LoopAllExcelFilesInFolder()

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "Z:\2016\Deal slips ordered mmddyy\"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

Set y = Workbooks.Open("Z:\2016\Report\SH Dealing yyyy.xlsx")
Set ws2 = y.Sheets("DealSlips")

'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Copy data on "Sheet1" sheet to "DealSlips" Sheet in other workbook
    With wb.Sheets("Sheet1")
       lRow = .Range("A" & Rows.Count).End(xlUp).Row
       ' lastRow = Sheets("Sheet1").Range("J" & Rows.Count).End(xlUp).Row
       .Range("A3:Z" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
    End With

    wb.Close SaveChanges:=True
    'Get next file name
    myFile = Dir
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 1

您可以通过更改以下行来获得所需的结果：

lRow = .Range("A" & Rows.Count).End(xlUp).Row

使用：

lRow = .UsedRange.Rows.Count

您的原始代码将计算特定列（在您的情况下是A列）的行数，而使用UsedRange的行将查看工作表的最后一行，包括仅包含格式的单元格。

更新：

找到最后一行而不用格式化计数单元格的另一种方法如下：

Dim lRow As Long, lRow2 As Long
lRow = wb.Sheets("Sheet1").Cells.Find(What:="*", _
        After:=wb.Sheets("Sheet1").Range("A1"), _
        Lookat:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row

 wb.Sheets("Sheet1").Range("A3:Z" & lRow).Copy

 lRow2 = ws2.Cells.Find(What:="*", _
        After:=ws2.Range("A1"), _
        Lookat:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
 ws2.Range("A" & lRow2).PasteSpecial xlPasteAll

更新2：

仔细查看您的代码后，我意识到lRow2抛出错误是因为Sheet实际上是空白的，所以我添加了一行代码，向单元格A1添加了“ Header”，以便适当地计算最后一行，我也不明白当我这样做时如何手动获得“正确”结果，但我得到的行比你多，但是请检查下面的代码，它对我有用（我认为），我还将带有代码（即Book1.xlsm）的工作簿移至您要遍历的文件夹之外，并添加了If语句以将“ SH Dealing yyyy.xlsx”工作簿从循环中排除：

Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook, y As Workbook
Dim myPath As String, myFile As String, myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long, lRow2 As Long
Dim ws2 As Worksheet

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "Z:\2016\Deal slips ordered mmddyy\"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

Set y = Workbooks.Open("Z:\2016\Report\SH Dealing yyyy.xlsx")
'amen
Set ws2 = y.Sheets("DealSlips")

'Loop through each Excel file in folder
Do While myFile <> ""
    If Left(myFile, 2) <> "SH" Then
        'Set variable equal to opened workbook
        Set wb = Workbooks.Open(Filename:=myPath & myFile)

        'Copy data on "Sheet1" sheet to "DealSlips" Sheet in other workbook
    lRow = wb.Sheets("Sheet1").Cells.Find(What:="*", _
            After:=wb.Sheets("Sheet1").Range("A1"), _
            Lookat:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row ' + 1
            y.Sheets("DealSlips").Range("A1").Value = "Header"
    lRow2 = y.Sheets("DealSlips").Cells.Find(What:="*", _
            After:=y.Sheets("DealSlips").Range("A1"), _
            Lookat:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False).Row + 1
            wb.Sheets("Sheet1").Range("A3:Z" & lRow).Copy ws2.Range("A" & lRow2)

        wb.Close SaveChanges:=True
        'Get next file name
        myFile = Dir
    Else
        myFile = ""
    End If
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

将多个工作簿的最后一行数据复制并粘贴到另一个工作簿中的工作表中

1 个答案: