今日の柴犬は、眠そうな顔をしています。もうすぐ寝そうです。
概要
「PowerShell」「バッチ .bat」とファイルのバックアップについて考えてみましたが、「EXCEL」で作るとどうなるか試してみました。
フォームも考えましたが、フォルダーにより情報が数百になることがありますので、シートで進めることにしました。
ダイヤログなどが使え、シートにバックアップ対象のフォルダーの中身をシートに書き出すこともできます。
ですので、一覧から選択することもできますのでかなり細かなことができます。
とりあえず、動きましたので記録します。
説明は後日徐々に追記したいと考えています。
今回お世話になった本です。
EXCELシート
次のようなエクセルシートを考えてみました。
セル「$C$1」の「フォルダーの一覧」をダブルクリックするとフォルダーを選択するダイヤログが開きますので選択します。
選択が完了すると選択したフォルダーの中にあるサブフォルダーとファイル名を探査しシートに表示します。
セル「$E$1」の「コピー先」をダブルクリックすると同様にダイヤログが開き、フォルダーを選択します。
選択が完了すると選択したフォルダーそのものがその下に表示されます。サブフォルダーではありません。
最上位にあるチェックボックスはすべてのチェックボックスにチェックを「入れる」または「外す」に使います。
セル「$A$1」の「コピー」をダブルクリックするとコピーを開始します。
VBエディターのコード
全てのコードは「ThisWorkbook」の中に記述しています。
シートのセルのダブルクリック時の直前に働くようにしてます。
「Cancel = True」はダブルクリックでセルが編集状態になるのをキャンセルするためです。
Option Explicit
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, _
Cancel As Boolean)
Dim BaseCol As Long: BaseCol = 3
Dim PasteCol As Long: PasteCol = 5
Dim FolderPath As String
Select Case Sh.Name
Case "Sheet1"
Select Case Target.Value
Case "フォルダーの一覧"
Cancel = True
FolderPath = SelectedFolder
If FolderPath = "" Then
Exit Sub
End If
Sh.Activate
Call WriteFolderCell(Sh.Name, BaseCol, FolderPath)
Call ShmakeCB(Sh.Name, BaseCol)
Case "コピー先"
Cancel = True
FolderPath = SelectedFolder
If FolderPath = "" Then
Exit Sub
End If
Sh.Activate
Call WriteFolderCell(Sh.Name, PasteCol, FolderPath, 1)
Case "コピー"
Cancel = True
'コピーを実行します。
Call CopyRun(Sh.Name, BaseCol, BaseCol + 1, PasteCol)
End Select
End Select
End Sub
ダイヤログを開きフォルダーを選択するようにして、選択したフォルダーのパスを含めた名前を返す関数にしてます。
'ダイヤログを表示します。
Public Function SelectedFolder() As String
Dim RES As String
RES = ""
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
RES = .SelectedItems(1)
End If
End With
SelectedFolder = RES
End Function
オプションの仮引数を使って引数を渡さない場合、オプションの仮引数「0」になるようにしています。
引数を渡す場合、オプションの仮引数はその値になります。
「count」が「0」の場合は、選択したフォルダー・ファイル情報を書き出し、「指定値」がある場合は、コピー先フォルダーの書き出し回数を指定したものとしています。
データを１行毎にシートに書きこむのは時間がかかるので、配列にデータをセットして、配列を複写する方法を行っています。
'引数でフォルダーパスを渡し内部フォルダーをシートに書き込みます。
Public Sub WriteFolderCell(ByVal ShName As String, _
ByVal WriteCol As Long, _
ByVal FolderPath As String, _
Optional ByVal count As Long = 0)
Dim FSO As Object
Dim Folders As Object
Dim Folder As Object
Dim Files As Object
Dim File As Object
Dim Data() As String
Dim DataR() As String
Dim buf As String
Dim EndRow As Long
Dim iRow As Long
Dim I As Long
Dim J As Long
Dim AddInd As Long
'既存のフォルダーデータを消去します。
With Worksheets(ShName)
.Range(.Cells(2, _
WriteCol), _
.Cells(ColEndRow(ShName, WriteCol), _
WriteCol + 1)).ClearContents
End With
'フォルダーデータを得るためオブジェクトを作成します。
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folders = FSO.GetFolder(FolderPath).SubFolders
'配列が満杯になったら追加する配列の数を 200 とします。
AddInd = 200
'VBAの配列は２次元の場合、列方向のみにしか追加できませんので行列が逆転するようにします。
redim Data(WriteCol To WriteCol + 1, 2 To AddInd)
'配列に書き込みます。
iRow = 2
If count = 0 Then
ReDim Data(WriteCol To WriteCol + 1, 2 To iRow + AddInd)
For Each Folder In Folders
With Worksheets(ShName)
Data(WriteCol, iRow) = Folder.Path
'配列が満杯か確認します。
If iRow = UBound(Data, 2) Then
ReDim Preserve Data(WriteCol To WriteCol + 1, 2 To iRow + AddInd)
End If
iRow = iRow + 1
End With
Next Folder
Set Files = FSO.GetFolder(FolderPath).Files
For Each File In Files
With Worksheets(ShName)
Data(WriteCol + 1, iRow) = File.Path
If iRow = UBound(Data, 2) Then
ReDim Preserve Data(WriteCol To WriteCol + 1, 2 To iRow + AddInd)
End If
iRow = iRow + 1
End With
Next File
Else
If count > 0 Then
ReDim Data(WriteCol To WriteCol, iRow To iRow + count - 1)
For I = 1 To count
With Worksheets(ShName)
Data(WriteCol, iRow) = FolderPath
iRow = iRow + 1
End With
Next I
End If
End If
'配列をシートに複写するため、行列の逆転を戻します。
ReDim Preserve Data(LBound(Data, 1) To UBound(Data, 1), LBound(Data, 2) To iRow - 1)
ReDim DataR(LBound(Data, 2) To iRow - 1, LBound(Data, 1) To UBound(Data, 1))
For I = LBound(Data, 1) To UBound(Data, 1)
For J = LBound(Data, 2) To UBound(Data, 2)
DataR(J, I) = Data(I, J)
Next J
Next I
'配列をシートに複写します。
With Worksheets(ShName)
.Range(.Cells(LBound(DataR, 1), _
LBound(DataR, 2)), _
.Cells(UBound(DataR, 1), _
UBound(DataR, 2))).Value = DataR
End With
'オブジェクトの参照を破棄します。
If Not Files Is Nothing Then
Set Files = Nothing
End If
Set Folders = Nothing
Set FSO = Nothing
End Sub
フォルダー・ファイル情報がある行にシェイプを作成します。
シェイプの名前は分離記号を「-」とし、その後「行番号」を続け、「行番号」を紐づけた形式にしています。
'シェイプ作成処理の入口です。
Public Sub ShmakeCB(ByVal ShName As String, _
ByVal FilePathCol As Long)
Dim EndRow As Long
Dim I As Long
'最終行を取得します。
EndRow = ColEndRow(ShName, FilePathCol)
'既存の一部を除いてシェイプを削除します。
Call CelldeleteCB(ShName, "test")
'判定列の個々のセルに値があれば、左横のセルにチェックボックスを作成します。
'シェイプの名前は「test-」に行番号を結合したものとします。
For I = 2 To EndRow
If CellExistVal(ShName, I, FilePathCol) Or _
CellExistVal(ShName, I, FilePathCol + 1) Then
Call CellmakeCB(Worksheets(ShName).Cells(I, FilePathCol - 1), "test-" & I, "")
End If
Next I
End Sub
作成するセルの位置大きさに合わせてチェックボックスを作成します。
'個々のシェイプを作成します。
Public Sub CellmakeCB(ByRef obCell As Range, _
ByVal CBName As String, _
ByVal MacName As String)
Dim Sh As Worksheet
Set Sh = obCell.Parent
'作成するセルの大きさに合わせてチェックボックスを作ります。
With Sh.CheckBoxes.Add(obCell.Left, _
obCell.Top, _
obCell.Width, _
obCell.Height)
.Name = CBName
.Caption = ""
.Value = xlOn
.OnAction = MacName
End With
End Sub
作成の更新の前に、既存のシェイプを一括削除します。
'指定のシェイプを削除します。
Public Sub CelldeleteCB(ByVal ShName As String, _
ByVal CBName As String)
Dim Sh As Worksheet
Dim Sp As Shape
Dim ObjRange As Object
Dim shp() As String
Dim icount As Long
Set Sh = Worksheets(ShName)
'削除の対象となるシェイプの一覧表を取得します。
icount = 0
For Each Sp In Sh.Shapes
If InStr(1, Sp.Name, CBName) > 0 Then
ReDim Preserve shp(icount)
shp(icount) = Sp.Name
icount = icount + 1
End If
Next Sp
'削除の対象を選択して削除を実行します。
If icount > 0 Then
Set ObjRange = Sh.Shapes.Range(shp)
If Not ObjRange Is Nothing Then
ObjRange.Select
ObjRange.Delete
Set ObjRange = Nothing
End If
End If
End Sub
指定列の最終行を返す関数です。
書式、数式により値がなくても最終行とされるので、とりあえず得られた最終行を遡って値がある最終行を求めています。
'シートの指定する列番号の最終行を返す関数
Public Function ColEndRow(ByVal ShName As String, _
ByVal ColNum As Long) As Long
Dim RES As Long
Dim buf As Long
RES = 0
With Sheets(ShName)
RES = .Cells(.Rows.count, ColNum).End(xlUp).Row
buf = .Cells(.Rows.count, ColNum + 1).End(xlUp).Row
If RES < buf Then
RES = buf
End If
'上で得られた値は、書式で設定があるときの最終行で空である場合がある
Do While .Cells(RES, ColNum).Value = "" And _
.Cells(RES, ColNum + 1).Value = "" And _
RES > 1
RES = RES - 1
Loop
End With
ColEndRow = RES
End Function
指定するセルに値があるかを返す関数です。
'シートのセル cells(Row, Col) に値の有無を返す関数
Public Function CellExistVal(ByVal ShName As String, _
ByVal Rownum As Long, _
ByVal ColNum As Long) As Boolean
Dim RES As Long
RES = False
RES = (Worksheets(ShName).Cells(Rownum, ColNum).Value <> "")
CellExistVal = RES
End Function
フォルダー・ファイル情報からコピー先のホルダーに複写します。
チェックボックスにチェックが入ったもののすべての行番号を配列にセットした後、配列から順次値と取り出して複写を実行しています。
'コピーを実行します
Public Sub CopyRun(ByVal ShName As String, _
ByVal FolderCol As Long, _
ByVal FileCol As Long, _
ByVal PasteCol As Long)
Dim Sh As Worksheet
Dim Sp As Shape
Dim val As Variant
Dim FSO As Object
Dim EndRow As Long
Dim iRow As Long
Dim I As Long
Dim Copytarget As String
Dim PasteFolder As String
Dim PasteFile As String
Dim list() As Long
'最終行を取得します。
EndRow = ColEndRow(ShName, FolderCol)
Set Sh = Worksheets(ShName)
'チェックボックスにチェックがはいったもののシェイプを拾います。
'そしてシェイプ名に紐づけられた行番号を配列に格納します。
I = 0
ReDim list(0 To EndRow - 1)
For Each Sp In Sh.Shapes
If InStr(1, Sp.Name, "test-") > 0 Then
If Sh.CheckBoxes(Sp.Name).Value = xlOn Then
val = Split(Sp.Name, "-")
list(I) = val(1)
I = I + 1
End If
End If
Next Sp
'少なくとも一つなければなりません。
If I = 0 Then
Exit Sub
End If
'余分な配列を削除します。
ReDim Preserve list(0 To I - 1)
'フォルダーデータを得るためオブジェクトを作成します。
Set FSO = CreateObject("Scripting.FileSystemObject")
iRow = 2
With Worksheets(ShName)
PasteFolder = .Cells(iRow, PasteCol).Value
PasteFile = .Cells(iRow, PasteCol).Value & "\"
'順次コピーを実行します。
For I = 0 To UBound(list)
Copytarget = .Cells(list(I), FolderCol).Value
If Copytarget <> "" Then
If Dir(Copytarget, vbDirectory) <> "" Then
FSO.GetFolder(Copytarget).Copy PasteFolder
End If
End If
Copytarget = .Cells(list(I), FileCol).Value
If Copytarget <> "" Then
If Dir(Copytarget, vbNormal) <> "" Then
FSO.GetFile(Copytarget).Copy PasteFile
End If
End If
Next I
End With
'オブジェクトの参照を破棄します。
Set FSO = Nothing
End Sub
最上位のチェックボックスのマクロ
標準モジュールを追加してその中に記述しています。
行っていることは、単に最上位のチェックボックスの状態の値を代入しているだけです。
Option Explicit
Public Sub CBValSet_Click()
Dim Sp As Shape
With ActiveSheet
For Each Sp In .Shapes
If InStr(1, Sp.Name, "test") > 0 Then
.CheckBoxes(Sp.Name).Value = .CheckBoxes("CBValSet").Value
End If
Next Sp
End With
End Sub