エクセルマクロが苦手
この時点で達成できることは、指定したディレクトリ内のすべてのサブフォルダーを再帰的に検索し、「Issues.xls*」を含むすべての Excel スプレッドシートを取得した後、Excel スプレッドシートの情報をコピーしてすべてを結合することです。マスター Excel スプレッドシート。すべての Issues.xlsx には 17 列あり、行番号は不明です。マクロをトリガーするボタンを同じシートに配置し、情報を組み合わせると、これらすべてを行うことができます。
私ができないのは、ボタンを「コントロールパネル」と呼ばれる別のシートに配置し、すべての結合情報を「マスターの問題」と呼ばれる別のシートに配置することです。これを行うと、「マスター課題」の部分的な情報しか取得できず、完全なデータは取得できません。
サブフォルダーごとに 1 つの Excel スプレッドシートしか取得できません。たとえば、3 つの課題がある場合、プログラムは 3 つの課題すべてではなく、1 つの Excel シートからのみデータを取得します。コードで愚かな間違いを犯さなければならないことはわかっていますが、どこで間違ったのかわかりません。
助けていただければ幸いです。どうもありがとうございました！！
**以下は私のコードです
ご協力ありがとうございました。
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