ソース
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