0

ディレクトリ内のすべてのフォルダーを走査し、複数の Excel スプレッドシートを 1 つにマージする 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

私はこのコードを2日間台無しにしようとしています。どこを間違えたのかよくわかりません。:(

4

1 に答える 1

0

vb.net にアクセスできる場合は、それを Excel-Interop と組み合わせて使用​​することをお勧めします。私はあなたが知っているのと同じことを試しました. Vb.net と相互運用機能の組み合わせは魅力的でした。

于 2012-09-24T16:06:19.467 に答える