0

我对 Excel 宏不太擅长

我现在能够实现的是递归搜索我指定的目录中的所有子文件夹，然后抓取所有包含“Issues.xls*”的excel电子表格，然后我将信息复制到excel电子表格中并合并主 Excel 电子表格。所有的 Issues.xlsx 都有 17 列和未知的行号。如果我在合并信息时将触发宏的按钮放在同一张表中，我就可以做到这一切。

我不能做的是将按钮放在另一个名为“控制面板”的工作表中，并将所有组合信息放在另一个名为“主问题”的工作表中。如果我这样做，我只能在“主问题”中获得部分信息，而不是完整数据。

每个子文件夹我只能得到一个 excel 电子表格。例如，如果我有 3 个问题，程序只会从一张 excel 工作表中获取数据，而不是所有 3 个问题。我知道我必须在代码中犯一些愚蠢的错误，但我看不出我在哪里做错了。

如果您能帮助我，我将不胜感激。非常感谢！！

** 下面是我的代码

谢谢您的帮助。

Option Explicit
Sub FileListingAllFolder()

Dim pPath As String
Dim FlNm As Variant
Dim ListFNm As New Collection ' create a collection of filenames

Dim ShtCnt As Integer
Dim Sht As Integer

Dim LR As Long, NR As Long
Dim wbkOld As Workbook, wbkNew As Workbook, ws 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
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' Create master workbook with single sheets
    Set wbkNew = ThisWorkbook
    Set ws = wbkNew.Sheets("Master Issues") 'sheet report is built into...edit to match

    If MsgBox("Import new data to this report?", vbYesNo) = vbNo Then Exit Sub

    If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
        ws.Range("A2:A" & Rows.Count).EntireRow.ClearContents
        NR = 2
    Else
        NR = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
    End If


    ' Filling a collection of filenames (search Excel files including subdirectories)
    ' Call FlSrch(ListFNm, pPath, "*.xls", True)
    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
        'Do While Len(FlNm) > 0
        'Open file
            Set wbkOld = Workbooks.Open(FlNm)
        'Find last row and copy data
            Sheets(1).Activate 'Sheets(1).Activate
            LR = Range("A" & Rows.Count).End(xlUp).Row   'find the bottom row of data...change to a different column if "A" isn't reliable for spotting this value
            Range("A2:A" & LR).EntireRow.Copy _
                ws.Range("A" & NR)
        'close file
            wbkOld.Close False
        'Next row
            NR = Range("A" & Rows.Count).End(xlUp).Row + 1
        'move file to "imported" folder
            'Name fPath & fName As fPathDone & fName         'optional
        'ready next filename
            'FlNm = Dir
        'Loop
    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 !"
        End
    End If

    Cells.Select
    Selection.EntireColumn.AutoFit
    Range("A1").Select
    ActiveSheet.Columns.AutoFit
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    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
4

1 回答 1

0

我认为您应该在所有参考文献前面加上适当的书/表！例如：

'Find last row and copy data
wbkOld.Sheets(1).Activate 'Sheets(1).Activate
LR = wbkOld.Range("A" & Rows.Count).End(xlUp).Row

如果你不这样做，你就会冒着引用 ActiveWorkbook 的 Activesheet 的风险，不管那是什么。你也可以用 改写上面的代码With，这样： 

'Find last row and copy data
With wbkOld
    .Sheets(1).Activate 'Sheets(1).Activate
    LR = .Range("A" & Rows.Count).End(xlUp).Row
End With
于 2012-05-24T21:28:57.063 回答