ソース

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