フォルダーバックアップ・プログラムの制作条件
① フォルダー内のファイルの有る無しや、アトリビュートなどは無視。
② フォルダーの名前のみのチェックで動作し、構造の読み取り結果はEXCELシートにデータを集計。
① フォルダー内のファイルの有る無しや、アトリビュートなどは無視。
② フォルダーの名前のみのチェックで動作し、構造の読み取り結果はEXCELシートにデータを集計。
③ フォルダーの違いは有り無し方式とし、結果はセル色を赤色変更にて文字で表示。
④ 同名のフォルダーの結果はセル色を赤色変更で表示し、変更操作は手動とする。
⑤ プログラムに依るコピー操作は、フォルダー単位（サブフォルダー含む）とする。
⑥ フォルダーの読込み結果は、双方の結果をEXCELシートに書き出し。
⑦ コピープログラムは、読込みプログラムと別構成で起動操作は別作業とする。
⑤ プログラムに依るコピー操作は、フォルダー単位（サブフォルダー含む）とする。
⑥ フォルダーの読込み結果は、双方の結果をEXCELシートに書き出し。
⑦ コピープログラムは、読込みプログラムと別構成で起動操作は別作業とする。
*****************************************************************************
★テスト用フォルダーの構成（オリジナル側のフォルダー）
青色がコピー前後のフォルダー構成が違う箇所とした。
★プログラムの動作結果の表示例（EXCELシート）
オリジナル側のフォルダー
コピー側のフォルダー
****************************************************************************
★フォルダー構成の読込みプログラム（先行版）
Public FSO As New FileSystemObject
Public OrginSheetName As String 'OrgFolderの構成を書き込むシート名
Public PassiveSheetName As String 'PassiveFolderの構成を書き込むシート名
Public SaveSheetName As String 'データ保存時のシート名
Public CurrRow As Long 'Excelシートの行番号
Public OrginFolderPath As String
Public PassiveFolderPath As String
Public SaveFolderPath As String
Sub フォルダー構造の取得()
' ****************************** フォルダーの指定
MsgBox "オリジナルフォルダーを指定してください"
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
OrginFolderPath = .SelectedItems(1)
End With
MsgBox "保存フォルダーを指定してください"
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
PassiveFolderPath = .SelectedItems(1)
End With
'****************************** 作動ボタンのシートを指定
Dim TopSheetName As String
TopSheetName = Worksheets(1).Name
'******************************* データを保存するシート名を作成
OrginSheetName = "Orign" & MakeNewSheetNo2(OrginFolderPath)
PassiveSheetName = "Passive" & MakeNewSheetNo2(PassiveFolderPath)
' ******************************* 出力するシートを2番目/3番目に作成
Worksheets.Add After:=Worksheets(TopSheetName)
ActiveSheet.Name = PassiveSheetName '3番目のシート
Worksheets.Add After:=Worksheets(TopSheetName)
ActiveSheet.Name = OrginSheetName '2番目のシート
'*********************************** オリジナルなフォルダーの構成を取得（再帰処理）
SaveSheetName = OrginSheetName
SaveFolderPath = OrginFolderPath
CurrRow = 0
Call GetAllSubfolders(OrginFolderPath)
'*********************************** 保存先フォルダーの構成を取得（再帰処理）
SaveSheetName = PassiveSheetName
SaveFolderPath = PassiveFolderPath
CurrRow = 0
Call GetAllSubfolders(PassiveFolderPath)
'********************************** 2つのフォルダー構成を比較し、無しフォルダーをチェック
Dim xLastRow As Long
Dim OrgRow As Long
Dim OrgMaxRow As Long
Dim PasRow As Long
Dim PasMaxRow As Long
'************* 各シートの最終行を取得
xlLastRow = Cells(Rows.Count, 2).Row 'Excelの最終行を取得
'*************** オリジナルシートのA列の最終行を取得
OrgMaxRow = Sheets(OrginSheetName).Cells(xlLastRow, 2).End(xlUp).Row
'*************** パッシブシートのA列の最終行を取得
PasMaxRow = Sheets(PassiveSheetName).Cells(xlLastRow, 2).End(xlUp).Row
'************ データを比較し、無いフォルダーが有れば、オリジナルシートのa列に”◯”マークを入力
For OrgRow = 1 To OrgMaxRow
For PasRow = 1 To PasMaxRow
If Sheets(OrginSheetName).Cells(OrgRow, 4).Value = Sheets(PassiveSheetName).Cells(PasRow, 4).Value Then
Sheets(OrginSheetName).Cells(OrgRow, 1).Value = "有"
Sheets(PassiveSheetName).Cells(PasRow, 1).Value = "有"
End If
Next
Next
For OrgRow = 1 To OrgMaxRow
If Sheets(OrginSheetName).Cells(OrgRow, 1).Value <> "有" Then
Sheets(OrginSheetName).Cells(OrgRow, 1).Value = "無"
Sheets(OrginSheetName).Cells(OrgRow, 1).Font.Color = RGB(255, 0, 0)
End If
Next
For PasRow = 1 To PasMaxRow
If Sheets(PassiveSheetName).Cells(PasRow, 1).Value <> "有" Then
Sheets(PassiveSheetName).Cells(PasRow, 1).Value = "無"
Sheets(PassiveSheetName).Cells(PasRow, 1).Font.Color = RGB(255, 0, 0)
End If
Next
'***********************************
MsgBox "データの取得が完了しました"
End Sub
'************************************************************************
Sub GetAllSubfolders(MyFolderPath As String) 'フォルダー構成を取得しEXCELへ出力（再帰処理）
Dim ParentFolder As Folder
Dim MyValue As String
Dim n As Integer
Set ParentFolder = FSO.GetFolder(MyFolderPath)
' *******************指定フォルダ内のサブフォルダー名を全て保存
Dim SubFolder As Folder
For Each SubFolder In ParentFolder.SubFolders
CurrRow = CurrRow + 1
Sheets(SaveSheetName).Cells(CurrRow, 2).Value = SubFolder.Name
MyValue = SubFolder.Path
Sheets(SaveSheetName).Cells(CurrRow, 3).Value = MyValue
n = InStr(MyValue, SaveFolderPath) + Len(SaveFolderPath)
Sheets(SaveSheetName).Cells(CurrRow, 4).Value = Mid(MyValue, n)
' ********************各サブフォルダに対してこの関数を再度呼出
Call GetAllSubfolders(SubFolder.Path)
Next
End Sub
'************************************************************
Function MakeNewSheetNo2(TgtFolderPath As String) As String
' ******************************* 出力するシート名を作成
Dim StrCnt As Integer
StrCnt = InStrRev(TgtFolderPath, "\", , vbTextCompare)
Dim NewSheetName As String
NewSheetName = Strings.Mid(TgtFolderPath, StrCnt)
If Len(NewSheetName) > 21 Then
NewSheetName = Left(NewSheetName, 21)
Else
End If
NewSheetName = GetTimeTxt(NewSheetName)
MakeNewSheetNo2 = FileNameNGReplace(NewSheetName)
End Function
'************************************************************
'時間をテキストで取得(フォルダー作成時に使う関数）
Function GetTimeTxt(ByVal Mytxt As String) As String
Dim A As Variant
A = CDate(Time)
GetTimeTxt = Mytxt & CStr(A)
End Function
'**************************************************************
'禁則文字列を削除(フォルダー作成時に使う関数）
Public Function FileNameNGReplace(sFileName As String) As String
Dim TmpStr As String
TmpStr = sFileName
TmpStr = Replace(TmpStr, "\", "")
TmpStr = Replace(TmpStr, "/", "")
TmpStr = Replace(TmpStr, ":", "")
TmpStr = Replace(TmpStr, "*", "")
TmpStr = Replace(TmpStr, "?", "")
TmpStr = Replace(TmpStr, """", "")
TmpStr = Replace(TmpStr, "<", "")
TmpStr = Replace(TmpStr, ">", "")
TmpStr = Replace(TmpStr, "|", "")
TmpStr = Replace(TmpStr, "[", "")
TmpStr = Replace(TmpStr, "]", "")
FileNameNGReplace = TmpStr
End Function
'***********************************************************
とりあえず、次はフォルダーの移動プログラムの作成です。
0 件のコメント:
コメントを投稿