Question

Excel宏不太好用

此时我能够实现的是递归搜索我指定的目录中的所有子文件夹，并获取包含“Issues.xls *”的所有excel电子表格，之后我复制excel电子表格中的信息，将所有内容合并到Master Excel SpreadSheet中。所有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

Answer 1

我认为您应该在所有参考文献前加上相应的书籍/表格！ E.g：

'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

无法使用Excel宏将所有数据保存到Excel电子表格中

1 个答案: