我正在尝试编写一个Excel宏,它将遍历目录中的所有文件夹,并将多个Excel电子表格合并为一个。所有excel电子表格都具有相同的格式。
我能够遍历目录中的所有文件夹,但是当我尝试将excel电子表格合并在一起时,我一直遇到错误。
这是我收到的错误消息:
运行时错误'1004':
Excel无法将工作表插入目标工作簿,因为 它包含的行和列比源工作簿少。移动 或者将数据复制到目标工作簿,您可以选择数据, 然后使用“复制”和“粘贴”命令将其插入到工作表中 另一本工作簿。
这是我到目前为止所做的:
Option Explicit
Sub FileListingAllFolder()
Dim pPath As String
Dim FlNm As Variant
Dim ListFNm As New Collection ' create a collection of filenames
Dim OWb As Workbook
Dim ShtCnt As Integer
Dim Sht As Integer
Dim MWb As Workbook
Dim MWs As Worksheet
Dim i As Integer
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
' Create master workbook with single sheets
Set MWb = Workbooks.Add(1)
MWb.Sheets(1).Name = "Result"
Set MWs = MWb.Sheets("Result")
' Filling a collection of filenames (search Excel files including subdirectories)
Call FlSrch(ListFNm, pPath, "*Issues.xls*", True)
' Print list to immediate debug window and as a message window
For Each FlNm In ListFNm ' cycle for list(collection) processing
'Start Processing here
Set OWb = Workbooks.Open(FlNm)
ShtCnt = ActiveWorkbook.Sheets.Count
For Sht = 1 To ShtCnt
Sheets(Sht).Copy After:=ThisWorkbook.Sheets(1)
Next Sht
OWb.Close False
Next FlNm
' Print to immediate debug window and message if no file was found
If ListFNm.Count = 0 Then
Debug.Print "No file was found !"
MsgBox "No file was found !"
MWb.Close False
End
End If
MWb.Activate
MWs.Activate
Cells.Select
Selection.EntireColumn.AutoFit
Range("A1").Select
Application.ScreenUpdating = True
Application.WindowState = xlMaximized
End
NextCode:
MsgBox "You Click Cancel, and no folder selected!"
End Sub
Private Sub FlSrch(pFnd As Collection, pPath As String, pMask As String, pSbDir As Boolean)
Dim flDir As String
Dim CldItm As Variant
Dim sCldItm As New Collection
' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"
' Searching files accordant with mask
flDir = Dir(pPath & pMask)
Do While flDir <> ""
pFnd.Add pPath & flDir 'add file name to list(collection)
flDir = Dir ' next file
Loop
' Procedure exiting if searching in subdirectories isn't enabled
If Not pSbDir Then Exit Sub
' Searching for subdirectories in path
flDir = Dir(pPath & "*", vbDirectory)
Do While flDir <> ""
' Do not search Scheduling folder
If flDir <> "Scheduling" Then
' Add subdirectory to local list(collection) of subdirectories in path
If flDir <> "." And flDir <> ".." Then If ((GetAttr(pPath & flDir) And _
vbDirectory) = 16) Then sCldItm.Add pPath & flDir
End If
flDir = Dir 'next file
Loop
' Subdirectories list(collection) processing
For Each CldItm In sCldItm
Call FlSrch(pFnd, CStr(CldItm), pMask, pSbDir) ' Recursive procedure call
Next
End Sub
我认为这是导致问题的部分。
For Each FlNm In ListFNm ' cycle for list(collection) processing
'Start Processing here
Set OWb = Workbooks.Open(FlNm)
ShtCnt = ActiveWorkbook.Sheets.Count
For Sht = 1 To ShtCnt
Sheets(Sht).Copy After:=ThisWorkbook.Sheets(1)
Next Sht
OWb.Close False
Next FlNm
我一直试图将这段代码搞砸了两天。我不太确定我做错了什么。 :(
答案 0 :(得分:0)
如果您访问vb.net,我建议您将其与Excel-Interop结合使用。 我尝试过你所知道的相同的事情 - 基本上,纯粹的VBA从未达到100%令人满意。 Vb.net和interop的结合就像一个魅力。