VBA
exc

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

无标题.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)
'ウレnヤ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