vba 指定フォルダ配下全部ファイルの指定シート、指定セルの値を抽出する。

![无标题.png](https://qiita-image-store.s3.amazonaws.com/0/197416/cefd855d-ba89-1c43-9cb7-c8668b96ee92.png)

ソース


Dim outSheet As Worksheet
Dim inputFileFolder As String
Dim totalCount As Integer
Dim successCount As Integer
Dim ngCount As Integer
Dim buf As String
Dim strDelSpace As String
Dim path As String
Dim sheetExFlg As Boolean
Dim SaveDir As String
'get wanted cell list
Dim list As Collection
Public saveFlg As Boolean
Dim j As Long
Public Sub mainPross(inputFileFolderP As String)
totalCount = 0
successCount = 0
ngCount = 0
Set outSheet = ActiveSheet
j = 0
inputFileFolder = inputFileFolderP
Set list = New Collection
If ActiveSheet.Name = "HOME" Then
If list.Count = 0 Then
Range(ActiveSheet.Cells(19, 1), ActiveSheet.Cells(19, 1).End(xlToRight)).Select
Dim c As Range
For Each c In Selection
If c.Value <> "" Then
With list
.Add c.Value
End With
End If
Next c
End If
If ActiveSheet.Cells(19, 1) = "" Then

    Range("A19").Interior.ColorIndex = 3
    MsgBox "ﾓﾚﾗﾜ｣ｬplease input the sheet name"
    Exit Sub
End If
If ActiveSheet.Cells(19, 2) = "" Then

    Range("B19").Interior.ColorIndex = 3
    MsgBox "ﾓﾚﾗﾜ, please input the wanted CELL "
    Exit Sub
End If

    Range("A19").Interior.ColorIndex = 4
    Range("B19").Interior.ColorIndex = 4
End If
Call ExecEachFolder(inputFileFolder, "**")
End Sub
Sub openExcelFile(filepath As String)
'ｳﾚｎﾔOｶｨ
Dim mySheet As Worksheet
Dim myBook As Workbook
i = 0
Set myBook = Workbooks.Open(fileName:=filepath, UpdateLinks:=0)
Application.ScreenUpdating = False
saveFlg = False
'=====================START=============================
For Each mySheet In myBook.Worksheets
If mySheet.Visible = xlSheetVisible Then

    '=============Иﾀ渧_ﾊｼ===================
    Call setZoom(mySheet, 85)

    Set mySheet = Nothing
End If
Next
'1ﾄｿﾒ侃ｨ､・ｷｩ`･ﾈ､ﾎﾟx談ｱ｣ｳﾖ
For Each mySheet In myBook.Worksheets
If mySheet.Visible = xlSheetVisible Then
mySheet.Select
    Set mySheet = Nothing
    Exit For
End If
Next
If saveFlg Then
myBook.Save
End If
'=====================END===============================
myBook.Close SaveChanges:=True
Set myBook = Nothing
End Sub
Public Function ExecEachFolder(folderPath As String, kaku As String)
Application.ScreenUpdating = False
Dim FSO As New FileSystemObject
' ･ﾕ･ｩ･・ﾀﾄﾚ､ﾎ･ﾕ･｡･､･・Iﾀ惕ｹ､・
Dim fe As FILE
For Each fe In FSO.GetFolder(folderPath).Files
Dim folderNm As String
folderNm = Split(folderPath, "\")(UBound(Split(folderPath, "\")))
'HOME･ｷｩ`･ﾈ､ﾋﾓ嵬ｵ､・ｿ･ﾕ･ｩ･・ﾀｴ贇ﾚ･ﾁ･ｧ･ﾃ･ｯ｡｢ｴ贇ﾚ､ｹ､・ﾐ｡｢ｳ猖ｫ､ﾋ､ﾊ､・
Dim folderFlg As Boolean

'･ﾕ･ｩ･・ﾀﾃ鉎ｰ､ﾏ僂ﾄﾜﾒｻﾓE､ﾋﾓ嵬ｵ､・ｿ僂ﾄﾜ､ﾋｴ贇ﾚ･ﾁ･ｧ･ﾃ･ｯ｡｢ｴ贇ﾚ､ﾎ因ｺﾏ｡｢ｳ猖ｫ､ﾋ我ｸ・
Dim rowIndex As Integer
Dim colIndex As Integer

Dim fp As String: fp = fe.path
Dim en As String: en = LCase(FSO.GetExtensionName(fp))

If (fe.Name Like kaku) And (en = "xls" Or en = "xlsx" Or en = "xlsm") And (fe.Attributes And 2) <> 2 Then
    ' If (fe.Name Like "ABCD") Then
    Call calcScales(fp)
    ' ｼﾊｽyﾓ・HOME･ｷｩ`･ﾈ､ﾋｱ桄ｾ
    totalCount = totalCount + 1
    ActiveSheet.Range("B1:B1").Select
    Selection.Value = Str(totalCount)
    ActiveCell.Offset(1, 0).Select
    Selection.Value = Str(successCount)
    ActiveCell.Offset(1, 0).Select
    Selection.Value = Str(ngCount)
    ' End If
End If
Set fe = Nothing
Next
' ･ｵ･ﾖ･ﾕ･ｩ･・ﾀ､ﾋﾔﾙ爾ｵﾄ､ﾋ量ﾋｹ､・
Dim fr As Folder
For Each fr In FSO.GetFolder(folderPath).SubFolders
Call ExecEachFolder(fr.path, kaku)
Set fr = Nothing
Next
Set FSO = Nothing
End Function
Sub calcScales(filepath As String)
'update by li 20180227 start 例 a入力すると、a列最終行の値を取得
Application.ScreenUpdating = False
Dim mySheet As Worksheet
Dim ws As Worksheet
Dim myBook As Workbook
Dim wb As Workbook
Dim fileNmMidNm As String

sheetExFlg = False
Dim closeFlg As Boolean
Dim directory As String
Dim fileName As String

fileName = Dir(filepath)
directory = Replace(filepath, fileName, "")
sheetExFlg = True
Dim lngWS  As Long

For lngWS = 1 To list.Count
    Windows("魚氏財務補助工具.xlsm").Activate
    If lngWS = 1 Then
        Worksheets("HOME").Cells(20 + j, lngWS) = Mid(filepath, InStrRev(filepath, "\") + 1)
    Else
            If list(lngWS) Like "[A-z]" = True Then
                cellStr = list(lngWS) & "1"
            Dim k As Integer
            k = Range(cellStr).Row
         
            Worksheets("HOME").Cells(20 + j, lngWS) = ExecuteExcel4Macro("'" & directory & "[" & fileName & "]" & list(1) & "'" & "!R" & k & "C" & Range(cellStr).Column)
            
            Do While ExecuteExcel4Macro("'" & directory & "[" & fileName & "]" & list(1) & "'" & "!R" & k & "C" & Range(cellStr).Column) <> 0
                Worksheets("HOME").Cells(20 + j, lngWS) = ExecuteExcel4Macro("'" & directory & "[" & fileName & "]" & list(1) & "'" & "!R" & k & "C" & Range(cellStr).Column)
                k = k + 5
            Loop

            Do While ExecuteExcel4Macro("'" & directory & "[" & fileName & "]" & list(1) & "'" & "!R" & k & "C" & Range(cellStr).Column) = 0

                If k > 1 Then
                    k = k - 1
                    Worksheets("HOME").Cells(20 + j, lngWS) = ExecuteExcel4Macro("'" & directory & "[" & fileName & "]" & list(1) & "'" & "!R" & k & "C" & Range(cellStr).Column)
                Else
                  Exit Do
                End If


            Loop
        Else
            cellStr = list(lngWS)
            Worksheets("HOME").Cells(20 + j, lngWS) = ExecuteExcel4Macro("'" & directory & "[" & fileName & "]" & list(1) & "'" & "!R" & Range(cellStr).Row & "C" & Range(cellStr).Column)
           
        End If
    End If
Next
j = j + 1

Set mySheet = Nothing

If sheetExFlg = False Then

    Windows("魚氏財務補助工具.xlsm").Activate
    Worksheets("HOME").Cells(20 + j, 1) = Mid(filepath, InStrRev(filepath, "\") + 1)
    Worksheets("HOME").Cells(20 + j, 1).Interior.ColorIndex = 3
    ngCount = ngCount + 1
    j = j + 1
Else
    successCount = successCount + 1
End If
Set myBook = Nothing
'update by li 20180227 end
End Sub
Public Sub clearData_Click()
Dim rc As Integer
rc = MsgBox("ﾓﾚﾗﾜ｣ｬAre you sure to do that kind of thing?", vbYesNo + vbQuestion, "ﾈｷﾈﾏ")
If rc = vbYes Then
    Range("A20:Z2000").ClearContents
    Range("A20:Z2000").ClearFormats
    Range("A20:Z2000").NumberFormat = "@"
    Cells(1, 2).Value = 0
    Cells(2, 2).Value = 0
    Cells(3, 2).Value = 0

End If
End Sub
'sheet "HOME"
Private Sub CommandButton1_Click()
Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = inputFileFolder.Text
If Not Application.FileDialog(msoFileDialogFolderPicker).Show Then Exit Sub
inputFileFolder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End Sub
Private Sub getData_Click()
If Len(inputFileFolder.Text) = 0 Then
Call MsgBox("ﾓﾚﾗﾜ｣ｬﾇ・菠・｡ﾔﾄｼﾂｷｾｶ", vbOKOnly + vbCritical)
Exit Sub
End If
Call mainPross(inputFileFolder.Text)
End Sub
Private Sub Workbook_Open()
Range("A20:Z2000").NumberFormat = "@"
End Sub