コード
※昔に書いた、穴だらけコード
Option Explicit
Option Base 1
Dim objFSO As FileSystemObject ' FSO
Dim wb As Workbook ' ワークブック 汎用
Dim ws As Worksheet ' ワークシート 汎用
Dim bolFind As Boolean ' フラグ用
Dim wsMenu As Worksheet ' 「メニュー」シート
Dim wsIchiran As Worksheet ' 「一覧」シート
Dim outputGyou As Long ' 出力する行番号
Dim lastGyou As Long ' データのある最終行
Dim errorFileList() As String ' エラーで開くことが出来なかったファイルのフルパスを格納する配列
Dim lngCellColor As Long ' セルの色の設定値
Dim wbKoushinList As Workbook ' 更新リストのファイル
Dim wsKoushinList As Worksheet ' 更新リストのシート
Dim koushinListGyou As Long ' 更新リストのシートで、現在対象となっている行番号
Dim wbNewFile As Workbook ' 新ファイル
Dim strOldFileName As String ' 旧ファイルのファイル名
Dim strNewFileName As String ' 新ファイルのファイル名
Dim strOldSheetName As String ' 旧シート名
Dim strNewSheetName As String ' 新シート名
Dim strOldFilePath As String ' コピー元のファイルパス
Dim strNewHozonPath As String ' 新保存先パス
Dim strReigaiPath As String ' 例外時の保存先パス
Dim reigaiFileNumber As Long ' ファイル名の例外に関する通し番号
Dim reigaiSheetNumber As Long ' シート名の例外に関する通し番号
Dim strKakuchoushi As String ' 新ファイル名に拡張子が無い場合の、付与する拡張子の文字列 「メニュー」シートで設定
Const cellColorNumber_1 As Long = 10092543 ' セル色1
Const cellColorNumber_2 As Long = 13434777 ' セル色2
Const reigaijiColorNumber As Long = 10040319 ' 例外時のセルの色
Const maxRetsu As Long = 17 ' データが入る最大列番号
Const pathRetsu As Long = 2 ' 一覧シートの「パス」列の列番号
Const fileNameRetsu As Long = 3 ' 一覧シートの「ファイル名」列の列番号
Const sheetNameRetsu As Long = 4 ' 一覧シートの「シート名」列の列番号
Const newHozonPathRetsu As Long = 6 ' 一覧シートの「新保存先パス」列の列番号
Const newFileNameRetsu As Long = 7 ' 一覧シートの「新ファイル名」列の列番号
Const newSheetNameRetsu As Long = 8 ' 一覧シートの「新シート名」列の列番号
Const jikkouRetsu As Long = 9 ' 一覧シートの「実行」列の列番号
Const jissaiHozonPathRetsu As Long = 11 ' 一覧シートの「実際の保存先パス」列の列番号
Const jissaiFilePathRetsu As Long = 12 ' 一覧シートの「実際のファイルパス」列の列番号
Const jissaiFileNamehRetsu As Long = 13 ' 一覧シートの「実際のファイル名」列の列番号
Const jissaiSheetNamehRetsu As Long = 14 ' 一覧シートの「実際のシート名」列の列番号
Const problemHozonRetsu As Long = 15 ' 一覧シートの「保存先の問題発生」列の列番号
Const problemFileNameRetsu As Long = 16 ' 一覧シートの「ファイル名の問題発生」列の列番号
Const problemSheetNameRetsu As Long = 17 ' 一覧シートの「シート名の問題発生」列の列番号
Sub MakeIchiran() ' ファイル名・シート名一覧作成処理
Dim strStartPath As String ' ファイル名・シート名一覧作成の基点となるフォルダのパス
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wsMenu = ThisWorkbook.Worksheets("メニュー")
If objFSO.FolderExists(wsMenu.Cells(4, 2).Value) = False Then
MsgBox "検索対象フォルダとして指定されたフォルダは存在しません"
Exit Sub
Else
strStartPath = wsMenu.Cells(4, 2).Value
If Right(strStartPath, 1) <> "\" Then ' パスの最後に￥が無い場合は、￥を付け足す
strStartPath = strStartPath & "\"
wsMenu.Cells(4, 2).Value = wsMenu.Cells(4, 2).Value & "\"
End If
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("一覧（コピー元）").Visible = True ' 隠しシートを再表示
Worksheets("一覧（コピー元）").Copy After:=Worksheets("メニュー")
Set wsIchiran = ActiveSheet
Worksheets("一覧（コピー元）").Visible = False ' シートを非表示に戻す
wsIchiran.Name = "一覧"
outputGyou = 2
lngCellColor = cellColorNumber_1
Erase errorFileList
ReDim Preserve errorFileList(1)
Call FileSheetSearch(strStartPath) ' ファイル名・シート名検索処理を呼び出し
wsIchiran.Activate
lastGyou = wsIchiran.Cells(wsIchiran.Rows.Count, sheetNameRetsu).End(xlUp).Row ' 最終行取得
If lastGyou > 1 Then ' 有効なデータがある場合
wsIchiran.Range(Cells(2, pathRetsu), Cells(lastGyou, maxRetsu)).Borders.LineStyle = True ' 罫線設定
For i = 2 To lastGyou
If wsIchiran.Cells(i, pathRetsu).Value <> "" Then
wsIchiran.Hyperlinks.Add Anchor:=Cells(i, pathRetsu), Address:=Cells(i, pathRetsu) ' パスにハイパーリンク付与
End If
Next i
End If
If errorFileList(1) <> "" Then ' エラーで開けなかったファイルがある場合
outputGyou = lastGyou + 3 ' リストの最終行の３行下から、エラーで開けなかったファイルのフルパスを出力
wsIchiran.Cells(outputGyou, 2).Value = "エラーで開くことの出来なかったファイル"
outputGyou = outputGyou + 1
For i = 1 To UBound(errorFileList) - 1 ' エラーのあったファイルのリストの配列の内容を出力
wsIchiran.Cells(outputGyou, 2).Value = errorFileList(i)
outputGyou = outputGyou + 1
Next i
MsgBox "エラーが発生して開くことの出来なかったファイルがあります。リストの最下段下部を参照してください"
End If
wsIchiran.Move
wsMenu.Cells(8, 2).Value = ActiveWorkbook.Name & ".xlsx"
Set objFSO = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "完了"
End Sub
Sub Change_FileName_SHeetName_SaveFolder() ' ファイル名・シート名・保存先変更処理
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wsMenu = ThisWorkbook.Worksheets("メニュー")
' 例外時の保存先フォルダのチェック
If objFSO.FolderExists(wsMenu.Cells(12, 2).Value) = False Then
MsgBox "例外時の保存先フォルダとして指定されたフォルダは存在しません"
Exit Sub
Else
strReigaiPath = wsMenu.Cells(12, 2).Value
If Right(strReigaiPath, 1) <> "\" Then ' パスの最後に￥が無い場合は、￥を付け足す
strReigaiPath = strReigaiPath & "\"
wsMenu.Cells(12, 2).Value = wsMenu.Cells(12, 2).Value & "\"
End If
End If
' 更新リストファイルのチェック
bolFind = False
For Each wb In Workbooks
If wb.Name = wsMenu.Cells(8, 2).Value Then
Set wbKoushinList = wb
bolFind = True
Exit For
End If
Next wb
If bolFind = False Then ' 更新リストファイルが現在開かれていない場合
MsgBox "更新リストファイルとして指定されているファイルが開かれていません"
Exit Sub
End If
bolFind = False
For Each ws In wbKoushinList.Sheets
If ws.Name = "一覧" Then
Set wsKoushinList = ws
bolFind = True
Exit For
End If
Next ws
If bolFind = False Then ' 更新リストファイルに「一覧」シートが存在しない場合
MsgBox "更新リストファイル内に「一覧」シートが存在しません"
Exit Sub
End If
If wsKoushinList.Cells(1, pathRetsu).Value <> "パス" Or wsKoushinList.Cells(1, problemSheetNameRetsu).Value <> "シート名の問題発生" Then
' 本来のフォーマットと違う場合
MsgBox "「一覧」シートのフォーマットが変更されています。行や列の追加・削除はしないでください"
Exit Sub
End If
' 新ファイルの拡張子設定
If ThisWorkbook.Worksheets("メニュー").OpXlsx.Value = True Then
strKakuchoushi = ".xlsx"
Else
strKakuchoushi = ".xls"
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wsKoushinList.Activate
If wsKoushinList.AutoFilterMode = True Then ' フィルタが設定されている場合
If wsKoushinList.AutoFilter.FilterMode = True Then ' フィルタで絞込みがされている場合
wsKoushinList.ShowAllData ' フィルタを解除しておく
End If
End If
lastGyou = wsKoushinList.Cells(wsKoushinList.Rows.Count, sheetNameRetsu).End(xlUp).Row ' 更新リストシートのデータのある最終行を求める
If lastGyou < 2 Then ' 一覧のデータが全く無い場合、処理を中止する
Set objFSO = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "一覧のデータが全くありませんでした"
Exit Sub
End If
wsKoushinList.Range(Cells(2, jissaiHozonPathRetsu), Cells(lastGyou, problemSheetNameRetsu)).Value = "－"
' "－"で初期化しておく
Call Check_MakeFolder ' 指定された保存先フォルダの存在確認と新規フォルダ作成の処理を呼び出し
' 例外に関する通し番号初期化
reigaiFileNumber = 1
reigaiSheetNumber = 1
koushinListGyou = 2
Do While koushinListGyou <= lastGyou ' ファイル名・シート名・保存先変更処理
With wsKoushinList
If .Cells(koushinListGyou, jikkouRetsu).Value <> "○" Then ' 「実行」列に「○」が入っていなければ、そのファイルは対象外
koushinListGyou = koushinListGyou + 1
Do While .Cells(koushinListGyou, fileNameRetsu).Value = "" ' 次のコピー元ファイルの範囲へ入るまで
koushinListGyou = koushinListGyou + 1
If koushinListGyou > lastGyou Then ' 最終行まで来ていたら、ループを抜ける
Exit Do
End If
Loop
Else ' 実行対象である場合
strOldFilePath = .Cells(koushinListGyou, pathRetsu).Value
If objFSO.FileExists(strOldFilePath) = False Then ' コピー元のファイルが存在しない場合
.Range(Cells(koushinListGyou, problemHozonRetsu), Cells(koushinListGyou, problemSheetNameRetsu)).Value = "コピー元のファイルが存在しません"
' 「保存先の問題発生」列～「シート名の問題発生」列
.Range(Cells(koushinListGyou, problemHozonRetsu), Cells(koushinListGyou, problemSheetNameRetsu)).Interior.Color = reigaijiColorNumber
' 「保存先の問題発生」列～「シート名の問題発生」列のセル色を例外時の色へ
koushinListGyou = koushinListGyou + 1
Do While .Cells(koushinListGyou, fileNameRetsu).Value = "" ' 次のコピー元ファイルの範囲へ入るまで
.Cells(koushinListGyou, jissaiSheetNamehRetsu).Value = "－" ' 「実際のシート名」列
.Cells(koushinListGyou, problemSheetNameRetsu).Value = "コピー元のファイルが存在しません" ' 「シート名の問題発生」列
.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
koushinListGyou = koushinListGyou + 1
If koushinListGyou > lastGyou Then ' 最終行まで来ていたら、ループを抜ける
Exit Do
End If
Loop
Else ' コピー元のファイルが存在する場合、通常のファイル名･シート名・保存先変更メイン処理を呼び出し
If Dir(strOldFilePath) = ThisWorkbook.Name Then
' このツールと同じファイル名のファイルは開かないようにする
.Cells(koushinListGyou, problemFileNameRetsu).Value = "コピー元のファイルパスのファイル名がこのツールと同じだったので、このファイルは処理をしません"
.Cells(koushinListGyou, problemSheetNameRetsu).Value = "コピー元のファイルパスのファイル名がこのツールと同じだったので、このファイルは処理をしません"
.Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
koushinListGyou = koushinListGyou + 1
Do While .Cells(koushinListGyou, fileNameRetsu).Value = "" ' 次のコピー元ファイルの範囲へ入るまで
.Cells(koushinListGyou, problemSheetNameRetsu).Value = "コピー元のファイルパスのファイル名がこのツールと同じだったので、このファイルは処理をしません" ' 「シート名の問題発生」列
.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
koushinListGyou = koushinListGyou + 1
If koushinListGyou > lastGyou Then ' 最終行まで来ていたら、ループを抜ける
Exit Do
End If
Loop
Else ' 通常処理
Call Koushin_Normal
End If
End If
End If
End With
Loop
' 実際の保存先パスと実際のファイルパス列にハイパーリンクを付与
koushinListGyou = 2
Do While koushinListGyou <= lastGyou
With wsKoushinList
If .Cells(koushinListGyou, jissaiHozonPathRetsu).Value <> "－" Then
.Hyperlinks.Add Anchor:=.Cells(koushinListGyou, jissaiHozonPathRetsu), Address:=.Cells(koushinListGyou, jissaiHozonPathRetsu).Value
End If
If .Cells(koushinListGyou, jissaiFilePathRetsu).Value <> "－" Then
.Hyperlinks.Add Anchor:=.Cells(koushinListGyou, jissaiFilePathRetsu), Address:=.Cells(koushinListGyou, jissaiFilePathRetsu).Value
End If
End With
koushinListGyou = koushinListGyou + 1
Loop
Set objFSO = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "完了"
End Sub
Sub Koushin_Normal() ' 通常のファイル名･シート名・保存先変更メイン処理
Dim nextFileStartGyou As Long ' 次のファイルの開始行
With wsKoushinList
' 新しい保存先に関する処理
If .Cells(koushinListGyou, newHozonPathRetsu).Value = "" Then ' 新保存先パスがブランクの場合は、例外時保存先を指定する
strNewHozonPath = strReigaiPath
.Cells(koushinListGyou, jissaiHozonPathRetsu).Value = strNewHozonPath
.Cells(koushinListGyou, problemHozonRetsu).Value = "新しい保存先の指定が無いため、例外時の保存先に格納しました"
.Cells(koushinListGyou, problemHozonRetsu).Interior.Color = reigaijiColorNumber
Else ' 新しい保存先の指定がある場合
strNewHozonPath = .Cells(koushinListGyou, newHozonPathRetsu).Value
If Right(strNewHozonPath, 1) <> "\" Then '新保存先パスの最後に「￥」が無い場合は付与する
strNewHozonPath = strNewHozonPath & "\"
End If
If objFSO.FolderExists(strNewHozonPath) = False Then ' 新しい保存先のフォルダが存在しない場合
strNewHozonPath = strReigaiPath
.Cells(koushinListGyou, jissaiHozonPathRetsu).Value = strNewHozonPath
.Cells(koushinListGyou, problemHozonRetsu).Value = "新しい保存先のフォルダが存在しないため、例外時の保存先に格納しました"
.Cells(koushinListGyou, problemHozonRetsu).Interior.Color = reigaijiColorNumber
Else ' 新しい保存先のフォルダが存在する場合
' 何もしない
End If
End If
' 新ファイル名に関する処理
strNewFileName = .Cells(koushinListGyou, newFileNameRetsu).Value
If strNewFileName = "" Then ' 新ファイル名の指定が無い場合
strNewFileName = .Cells(koushinListGyou, fileNameRetsu).Value
Else ' 新ファイル名の指定がある場合
If InStr(strNewFileName, ".xls") > 0 Then ' 新ファイル名に拡張子が含まれている場合
' 何もしない strNewFileNameはそのまま使用
Else ' 新ファイル名に拡張子が含まれていない場合は、拡張子を付与する
If ThisWorkbook.Worksheets("メニュー").OpXlsx.Value = True Then
strNewFileName = strNewFileName & strKakuchoushi
Else
strNewFileName = strNewFileName & strKakuchoushi
End If
End If
End If
If objFSO.FileExists(strNewHozonPath & strNewFileName) = True Then ' 保存先に既に新ファイル名と同名ファイルがある場合
strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi ' ファイル名を例外用のものへ
.Cells(koushinListGyou, problemFileNameRetsu).Value = "新しい保存先に同名のファイルがあるため、例外時のファイル名にしました"
.Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
Do While objFSO.FileExists(strNewHozonPath & strNewFileName) = True
' 新保存先に同じファイル名のファイルがある可能性があるので､重複がなくなるまでreigaiFileNumberをカウントアップする
reigaiFileNumber = reigaiFileNumber + 1
strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi
Loop
reigaiFileNumber = reigaiFileNumber + 1
End If
' コピー元ファイルを開き、名前を付けて保存で一旦保存しておく
On Error GoTo ErrorHandler_1
Workbooks.Open Filename:=strOldFilePath, ReadOnly:=True, UpdateLinks:=0
' 新ファイルを読み取り専用、リンク更新なしで開く
On Error GoTo 0
Set wbNewFile = ActiveWorkbook
On Error GoTo ErrorHandler_3
If Right(strNewFileName, 5) = ".xlsx" Then ' 新ファイル名の末尾が「.xlsx」の場合
wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlOpenXMLWorkbook
ElseIf Right(strNewFileName, 4) = ".xls" Then ' 新ファイル名の末尾が「.xls」の場合
wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlExcel8
ElseIf Right(strNewFileName, 5) = ".xlsm" Then ' 新ファイル名の末尾が「.xlsm」の場合
wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else ' 使用できない新ファイル名が指定されている場合
strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi ' ファイル名を例外用のものへ
.Cells(koushinListGyou, problemFileNameRetsu).Value = "新ファイル名の拡張子が「.xlsx」「.xls」「.xlsm」以外であるため、例外時のファイル名にしました"
.Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
Do While objFSO.FileExists(strNewHozonPath & strNewFileName) = True
' 新保存先に同じファイル名のファイルがある可能性があるので､重複がなくなるまでreigaiFileNumberをカウントアップする
reigaiFileNumber = reigaiFileNumber + 1
strNewFileName = "例外ファイル名_" & reigaiFileNumber & strKakuchoushi
Loop
reigaiFileNumber = reigaiFileNumber + 1
If strKakuchoushi = ".xlsx" Then
wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlOpenXMLWorkbook
Else
wbNewFile.SaveAs Filename:=strNewHozonPath & strNewFileName, FileFormat:=xlExcel8
End If
End If
On Error GoTo 0
' 新ファイルの実際の保存先、実際のファイル名、実際のシート名を入力
.Cells(koushinListGyou, jissaiHozonPathRetsu).Value = strNewHozonPath
.Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName
.Cells(koushinListGyou, jissaiFileNamehRetsu).Value = strNewFileName
If koushinListGyou >= lastGyou Then ' データのある最終行まで既に到達していた場合
nextFileStartGyou = koushinListGyou + 1
Else
nextFileStartGyou = koushinListGyou + 1
Do While .Cells(nextFileStartGyou, fileNameRetsu).Value = "" ' 次のファイルの範囲に入るまで、nextFileStartGyouをカウントアップ
nextFileStartGyou = nextFileStartGyou + 1
If nextFileStartGyou > lastGyou Then ' 最終行まで来ていたら、ループを抜ける
Exit Do
End If
Loop
End If
Do While koushinListGyou < nextFileStartGyou
strOldSheetName = .Cells(koushinListGyou, sheetNameRetsu).Value
strNewSheetName = .Cells(koushinListGyou, newSheetNameRetsu).Value
If strNewSheetName = "" Then ' 新シート名がブランクの場合は、旧シート名を新シート名とする
strNewSheetName = strOldSheetName
End If
bolFind = False
For Each ws In wbNewFile.Worksheets ' 新ファイルのシートに、旧シート名が存在することのチェック
If ws.Name = strOldSheetName Then
ReturnFromError_2:
On Error GoTo ErrorHandler_2
ws.Name = strNewSheetName
.Cells(koushinListGyou, jissaiSheetNamehRetsu).Value = strNewSheetName
.Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName ' 「実際のファイルパス」列にも入力しておく
On Error GoTo 0
bolFind = True
Exit For
End If
Next ws
If bolFind = False Then ' 新ファイルのシートに、旧シート名が存在しない場合
.Cells(koushinListGyou, problemSheetNameRetsu).Value = "旧シート名のシートが新ファイルに存在しないので、シート名の変更はしませんでした"
.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
.Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName ' 「実際のファイルパス」列にも入力しておく
End If
koushinListGyou = koushinListGyou + 1
Loop
ReturnFromError_3:
wbNewFile.Close SaveChanges:=True ' ファイルを閉じる
ReturnFromError_1:
End With
Exit Sub
' 以下、エラー時処理
ErrorHandler_1: ' コピー元ファイルを開く時にエラーが発生した場合の処理
wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Value = "何らかの理由により、コピー元ファイルオープン時にエラー発生"
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、コピー元ファイルオープン時にエラー発生"
wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
koushinListGyou = koushinListGyou + 1
Do While wsKoushinList.Cells(koushinListGyou, fileNameRetsu).Value = "" ' 次のコピー元ファイルの範囲へ入るまで
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、コピー元ファイルオープン時にエラー発生" ' 「シート名の問題発生」列
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
koushinListGyou = koushinListGyou + 1
If koushinListGyou > lastGyou Then ' 最終行まで来ていたら、ループを抜ける
Exit Do
End If
Loop
Resume ReturnFromError_1
ErrorHandler_2: ' シート名変更時にエラーが発生した場合の処理
strNewSheetName = "例外時のシート名_" & reigaiSheetNumber
reigaiSheetNumber = reigaiSheetNumber + 1
wsKoushinList.Cells(koushinListGyou, jissaiSheetNamehRetsu).Value = strNewSheetName
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、シート名変更時にエラーが発生（シート名の重複が考えられます）ため、シート名は例外時のものとしました"
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
wsKoushinList.Cells(koushinListGyou, jissaiFilePathRetsu).Value = strNewHozonPath & strNewFileName ' 「実際のファイルパス」列にも入力しておく
Resume ReturnFromError_2
ErrorHandler_3: ' 新ファイル保存時にエラーが発生した場合の処理
wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Value = "何らかの理由により、新ファイル保存時にエラー発生"
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、新ファイル保存時にエラー発生"
wsKoushinList.Cells(koushinListGyou, problemFileNameRetsu).Interior.Color = reigaijiColorNumber
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
koushinListGyou = koushinListGyou + 1
Do While wsKoushinList.Cells(koushinListGyou, fileNameRetsu).Value = "" ' 次のコピー元ファイルの範囲へ入るまで
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Value = "何らかの理由により、新ファイル保存時にエラー発生" ' 「シート名の問題発生」列
wsKoushinList.Cells(koushinListGyou, problemSheetNameRetsu).Interior.Color = reigaijiColorNumber
koushinListGyou = koushinListGyou + 1
If koushinListGyou > lastGyou Then ' 最終行まで来ていたら、ループを抜ける
Exit Do
End If
Loop
Resume ReturnFromError_3
End Sub
Sub Check_MakeFolder() ' 指定された保存先フォルダの存在確認と新規フォルダ作成
Dim objFolder As Object ' フォルダ
Dim pathBunkatsu() As String ' パスを「￥」区切りで分割し、格納する配列
Dim strPath As String
Dim lastPath As String
Dim currentGyou As Long ' 現在検索中の行数
Dim i As Long
For currentGyou = 2 To lastGyou
If wsKoushinList.Cells(currentGyou, fileNameRetsu).Value <> "" And wsKoushinList.Cells(currentGyou, newHozonPathRetsu).Value <> "" Then
' 「ファイル名」列に値があり、かつ「新保存先パス」列に値がある場合
strPath = wsKoushinList.Cells(currentGyou, newHozonPathRetsu).Value
Erase pathBunkatsu
ReDim Preserve pathBunkatsu(1)
' パスの文字列を「￥」区切りで後ろ側から分解していく
On Error GoTo ErrorHandler
Do While Dir(strPath, vbDirectory) = ""
pathBunkatsu(UBound(pathBunkatsu)) = Mid(strPath, (InStrRev(strPath, "\")), (Len(strPath) - (InStrRev(strPath, "\")) + 1))
ReDim Preserve pathBunkatsu(UBound(pathBunkatsu) + 1)
strPath = Mid(strPath, 1, (InStrRev(strPath, "\") - 1))
If Dir(strPath, vbDirectory) <> "" Then
lastPath = strPath
Exit Do
End If
Loop
On Error GoTo 0
i = UBound(pathBunkatsu) - 1
Do While i > 0
lastPath = lastPath & pathBunkatsu(i)
MkDir (lastPath) ' フォルダ作成
i = i - 1
Loop
End If
ReturnFromError:
Next currentGyou
Erase pathBunkatsu
Exit Sub
ErrorHandler:
' 特に何もせず、ReturnFromErrorまで戻る
Resume ReturnFromError
End Sub
Sub FileSheetSearch(strStartPath As String) ' フォルダ内のファイル名・シート名の取得（再帰処理でサブフォルダも）
Dim objFile As Object ' ファイル
Dim objFolder As Object ' フォルダ
Dim objSubFolder As Object ' サブフォルダ
Dim wbTarget As Workbook ' 検索対象のファイル
Dim lngWsCount As Long ' シートのカウント用変数
With objFSO
Set objFolder = .GetFolder(strStartPath)
' フォルダ内のファイルのデータを出力
For Each objFile In objFolder.Files
If .GetFile(objFile).Name Like "*.xlsx" Or _
.GetFile(objFile).Name Like "*.xls" Or _
.GetFile(objFile).Name Like "*.xlsm" Then
' .xlsx .xls .xlsm のエクセルファイルだった場合
If .GetFile(objFile).Name = ThisWorkbook.Name Then
' 自分自身と同じ名前のファイルだった場合は、開かずにエラー扱いとする
errorFileList(UBound(errorFileList)) = objFSO.GetFile(objFile).Path
ReDim Preserve errorFileList(UBound(errorFileList) + 1)
Else
On Error GoTo ErrorHandler ' ファイルが開けなかった場合は、ErrorHandlerへ
Workbooks.Open Filename:=.GetFile(objFile).Path, ReadOnly:=True, UpdateLinks:=0
' ファイルを読み取り専用で開く
On Error GoTo 0
Set wbTarget = ActiveWorkbook
wsIchiran.Activate
wsIchiran.Cells(outputGyou, pathRetsu).Value = .GetFile(objFile).Path
wsIchiran.Cells(outputGyou, fileNameRetsu).Value = wbTarget.Name
wsIchiran.Cells(outputGyou, jikkouRetsu).Value = "○"
wsIchiran.Range(Cells(outputGyou, pathRetsu), Cells(outputGyou, maxRetsu)).Interior.Color = lngCellColor
lngWsCount = 1
For Each ws In wbTarget.Sheets ' 全シートを出力
wsIchiran.Cells(outputGyou, sheetNameRetsu).Value = ws.Name
If lngWsCount > 1 Then
' ２シート目以降は「新保存先パス」・「新ファイル名」・「実行」列に「****」を入力 セル色も設定
wsIchiran.Cells(outputGyou, newHozonPathRetsu).Value = "****"
wsIchiran.Cells(outputGyou, newFileNameRetsu).Value = "****"
wsIchiran.Cells(outputGyou, jikkouRetsu).Value = "****"
wsIchiran.Range(Cells(outputGyou, pathRetsu), Cells(outputGyou, maxRetsu)).Interior.Color = lngCellColor
End If
outputGyou = outputGyou + 1
lngWsCount = lngWsCount + 1
Next ws
If lngCellColor = cellColorNumber_1 Then ' セル色の入れ替え
lngCellColor = cellColorNumber_2
Else
lngCellColor = cellColorNumber_1
End If
wbTarget.Close SaveChanges:=False
End If
End If
ReturnFromError:
Next objFile
' 再帰処理でサブフォルダのデータを出力する
For Each objSubFolder In objFolder.SubFolders
Call FileSheetSearch(objSubFolder.Path) ' ここで自分自身を呼び出す再帰処理
Next objSubFolder
End With
Exit Sub
ErrorHandler: ' エラーでファイルが開けなかった場合の処理
errorFileList(UBound(errorFileList)) = objFSO.GetFile(objFile).Path ' エラーのファイルリストに追加
ReDim Preserve errorFileList(UBound(errorFileList) + 1)
Resume ReturnFromError
End Sub
Sub SelectFolder_Ichiran() ' 一覧作成の開始フォルダを選択するダイアログを開く
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Cells(4, 2).Value = .SelectedItems(1) & "\"
Else
MsgBox "キャンセルされました"
End If
End With
End Sub
Sub SelectFolder_Reigai() ' 例外時の保存フォルダを選択するダイアログを開く
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Cells(12, 2).Value = .SelectedItems(1) & "\"
Else
MsgBox "キャンセルされました"
End If
End With
End Sub
Sub KoushinListFileSelect() ' 更新リストのファイルを選択するフォームを開く
Load FormFileSelect
' 現在開いているファイルをフォームのリストに追加
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then ' 自分自身はリストに入れない
FormFileSelect.ListFileName.AddItem wb.Name
End If
Next wb
FormFileSelect.Show
End Sub