时间戳

首页 > 解决方案 > 循环遍历多个工作簿不起作用

excel - 循环遍历多个工作簿不起作用

问题描述

我有一个代码循环遍历用户选择的文件夹中的所有工作簿并从所有工作表中获取列名。请注意，单个工作表选项卡中可能有多个列名。因此，代码在其中包含“产品”的第一列中搜索并复制整行直到最后一个非空列并将它们粘贴到ThisWorkbook.Sheets("Column Names").

此代码打开工作簿，在每个工作表选项卡中搜索文本“产品”，复制列名并关闭工作簿而不保存。

我正在使用下面的代码来获取列名。它仅适用于 1 个工作簿，并且当代码打开第二个工作簿时，它会在突出显示的行中引发错误。

任何人都请帮助我确定我做错了什么。

Option Explicit
Dim i, ShtCnt As Integer
Dim ws, CurSht As Excel.Worksheet
Dim cell As Range
Dim EmpCell As Integer
Dim NonEmpCell As Integer
Dim lRow As Long
Dim ThiswblRow, ThiswblRow2 As Long
Dim lCol As Long
Dim FldrPicker As FileDialog
Dim wb As Workbook
Dim myExtension, filepath, filepathSrc, filepathDest, fileSaveName, filename, Template, TempLocPath, ShtNameRaw, ShtNameTemp, SlrName As String


'Step 1

Public Sub LoopAllExcelFilesInAFolder()
    
'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 = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        filepath = .SelectedItems(1) & "\"
    End With
    


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

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

'Target Path with Ending Extention
  TempLocPath = Dir(filepath & myExtension)

'Loop through each Excel file in folder
  Do While TempLocPath <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(filename:=filepath & TempLocPath)
      
    filename = ActiveWorkbook.Name
    Workbooks(filename).Activate
    
    
'Call Find_Product_in_each_sheet_loop

For ShtCnt = 1 To ActiveWorkbook.Worksheets.Count
'On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(ShtCnt) 
lRow = ws.Range("A100000").End(xlUp).Row     -->  Getting error in this line

'Call Find_Product(ws)

For i = 1 To lRow

    lRow = ws.Range("A100000").End(xlUp).Row

    If InStr(ws.Cells(i, 1), "Product") <> 0 Or InStr(ws.Cells(i, 1), "Model") <> 0 Then
    
    ThiswblRow = ThisWorkbook.Sheets("Column Names").Range("B100000").End(xlUp).Row + 1
'Workbook Name
    ThisWorkbook.Sheets("Column names").Range("B" & ThiswblRow) = ActiveWorkbook.Name
    ws.Activate
'Sheet Name
    ThisWorkbook.Sheets("Column names").Range("C" & ThiswblRow) = ActiveSheet.Name
    
    lCol = ws.Cells(i, Columns.Count).End(xlToLeft).Column
    
    ws.Range(Cells(i, 1), Cells(i, lCol)).Select

'Column Names

    ws.Range(Cells(i, 1), Cells(i, lCol)).Copy ThisWorkbook.Sheets("Column Names").Range("D" & ThiswblRow)
    
    
End If
    
Next i

ThiswblRow = Empty
lRow = Empty

'Next j

Next ShtCnt

    ThiswblRow = ThisWorkbook.Sheets("Column Names").Range("A100000").End(xlUp).Row + 1
    ThiswblRow2 = ThisWorkbook.Sheets("Column Names").Range("B100000").End(xlUp).Row
    
'Partner Name

    Workbooks(filename).Sheets("Request Form").Activate
    Workbooks(filename).Sheets("Request Form").Columns(1).Select
    With Selection
    .Find(What:="Partner Name", After:=ActiveCell, LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 1).Copy ThisWorkbook.Sheets("Column Names").Range("A" & ThiswblRow & ":A" & ThiswblRow2)
    End With
    
lRow = Empty
ThiswblRow = Empty
ThiswblRow2 = Empty


'Close Workbook without saving
      wb.Close SaveChanges:=False
      
'Get next file name
      TempLocPath = Dir
  Loop
  
ThisWorkbook.Sheets("Column Names").UsedRange.WrapText = False
  
ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
MsgBox ("Done")
  
End Sub

标签： excelvba

解决方案

您很可能有一个旧格式 (*.xls) 的 Excel 文件。在旧格式中，工作表只有 64k 行，所以使用类似的东西会A100000失败，因为根本没有这样的单元格。

不要使用这样的神奇数字。工作表中的总行数为ws.rows.count，无论工作表有多少行，它都有效。将行更改为

lRow = ws.Cells(ws.rows.count, 1).End(xlUp).Row

或者，如果您愿意

lRow = ws.Range('A' & ws.rows.count).End(xlUp).Row

PS：你应该缩进你的代码，你呈现它的方式几乎是不可读的。我正要放弃，因为几乎不可能知道循环从哪里开始和结束。

推荐阅读