Не удается сохранить все данные в таблицу Excel с помощью Excel Macro

Question

Я не так хорошо с Excel Macro

Что я могу достичь в этой точке, чтобы рекурсивно искать все вложенные папки в каталоге указываю и захватите всю таблицу Excel, содержащую «Issues.xls», после чего я скопирую информацию в таблицу 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

Я думаю, вы должны прикрепить все свои ссылки соответствующей книгой/листом! Например .:

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

Если вы не сделаете этого, вы берете на себя риск ссылки на ActiveSheet в ActiveWorkbook, что бы это ни. Вы также можете перефразировать код выше, используя 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