Excel VBA シート挿入 password設定 マクロ

失礼いたします。下記の作業をマクロ化したいのですが、なかなか上手くいきません…どなたかコードをご教授願えますと幸いです。

①"E:\VBA\シート挿入.xlsm"の"Sheet1"を"E:\VBA\対象フォルダ"にある全てのエクセルファイルの先頭にコピー挿入する。
②挿入が完了したエクセルファイルは全てパスワード="aaa"をつけ、上書き保存する。

よろしくお願いいたします。

No.1 回答者： WindFaller 回答日時： 2016/09/05 15:15

こんにちは。

これは、内容的に思った以上に難しくややこしいです。

また、唐突ですが、ここのところ、私のコードが複雑だから、ボツにするという人が何人かいるようです。私は、そんなにマクロはうまくもありません。また、回答者にも、同様の、複雑なマクロは書くべきではないという意見を持つ人がいます。今回の内容の3分の1は、エラー対策です。

それで手を抜いたコードをポストして、BAになったとしても、VBAのプログラミングとして、安易なコードは、結果的には自分のためにならないと思います。

なお、これは、Excel 2013 で作りました。互換性は考慮されていますが、パスワード周りが、多少不安が残ります。果たして、そんな仕様だったかどうかということです。必ず、パスワードが入っていないファイルを対象としています。

また、失敗の可能性は、多少なりとも考慮しておいてください。Pkzipなどで、フォルダごとバックアップをとっておくと良いかもしれません。元に戻すマクロも用意したものの、必ずしも成功するとは限りませんから。

'//
Sub ArrangingAllxlFiles()
　Dim fName, myPath As String
　Dim i As Long, j As Long
　Dim wb As Workbook
　Dim sh As Worksheet
　Dim myFiles()
　Dim fn
　Const PWD As String = "aaa" '　パスワード
　Set sh = ThisWorkbook.Worksheets(1)
''　("E:\VBA\シート挿入.xlsm")
　'なるべくSheet1 とかいう名称でないほうがよいです。
　
　myPath ="E:\VBA\対象フォルダ\" '必ず末尾には、『￥』を入れてください。
　fName = Dir(myPath & "*.xls?", vbNormal)
　Do While fName <> ""
　　If (GetAttr(myPath & fName) And vbNormal) = vbNormal Then
　　　If ThisWorkbook.Name <> fName Then '同名ファイル名不可
　　　　ReDim Preserve myFiles(i)
　　　　myFiles(i) = fName
　　　　i = i + 1
　　　End If
　　End If
　　fName = Dir
　Loop
　Application.ScreenUpdating = False
　For Each fn In myFiles
　　On Error Resume Next
　　If Right(fn, 4) = ".xls" Then Stop
　　With Workbooks.Open(myPath & fn, , , , "", "")　　　
　　　If Err.Number <> 1004 Then
　　　　Err.Clear
　　　　sh.Copy before:=.Worksheets(1)
　　　　'旧バージョンへの対策
　　　　If Err.Number = 1004 Then
　　　　　.Worksheets.Add before:=.Worksheets(1)
　　　　　sh.UsedRange.Copy .Worksheets(1).Range("A1")
　　　　　.Worksheets(1).Name = sh.Name　'こちらは名前が変わらないい時がある
　　　　End If
　　　　Application.DisplayAlerts = False
　　　　.SaveAs myPath & fn, , PWD, PWD
　　　　Application.DisplayAlerts = True
　　　　.Close False
　　　Else
　　　　Debug.Print fn　'エラーを起こしたファイル名を記録
　　　End If
　　　If Err() = 0 Then j = j + 1　'エラー無しファイルのカウント
　　End With
　　Err.Clear
　　On Error GoTo 0
　Next fn
　Application.ScreenUpdating = True
　MsgBox UBound(myFiles) + 1 & "中、" & j & "個設定しました。", vbInformation
End Sub

'//

Debug.Print fn は、問題ないと分かり、不要になりましたら、その行を削除して構いません。

この回答へのお礼

御礼が遅れて申し訳ございません。無事動きました！この度は誠にありがとうございました。

お礼日時：2016/09/11 21:49