- ベストアンサー
エクセルVBAで読み取りパスワード回避
cj_moverの回答
- cj_mover
- ベストアンサー率76% (292/381)
(前の投稿の続きです) Sub Re8470695j() ' ' ーーーーーーーーー ' ' フォルダ指定 Dim sDir As String ' 指定フォルダ名 With Application.FileDialog(msoFileDialogFolderPicker) ' ' ▲例:自ブックのフォルダの一階層上を表示 .InitialFileName = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1) ' ▲仮の例です。変更/省略可。 ' ' ファイル名一覧取得 If .Show = True Then sDir = .SelectedItems(1) Else Exit Sub End If End With ' ' ーーーーーーーーー ' ' ファイル名一覧取得 'Dim oWSH Dim oWSH As Object ' WScript.Shell As IWshRuntimeLibrary.WshShell (Windows Scripting Host Object Model) Dim sCmd As String ' コマンドプロンプト Dim sBuf As String ' 転記元ファイル名一覧(CrLf区切り) Set oWSH = CreateObject("WScript.Shell") ' ' コマンドプロンプト:指定フォルダの"*xls*"ファイル名の一覧を取得 sCmd = "%ComSpec% /c dir " & sDir & "\*.xls/B" With oWSH.Exec(sCmd) ' コマンド実行 Do While .Status = 0 DoEvents ' 非同期実行を待機 Loop ' ' 転記元ファイル名一覧(CrLf区切り)を読み込み(前後にCrLf在り) sBuf = vbCrLf & .StdOut.ReadAll End With Set oWSH = Nothing If sBuf = vbCrLf Then MsgBox "空っぽ、中止": Exit Sub ' ' ーーーーーーーーー ' ' 転記元ファイル名一覧から自ブックを除外 If ThisWorkbook.Path = sDir Then sBuf = Replace(sBuf, vbCrLf & ThisWorkbook.Name, "") End If ' ' ーーーーーーーーー ' ' 転記元の各ブックが実行前から開いていた場合 ' ' 未保存なら上書きを強制|または処理中止 Dim oWbk As Workbook For Each oWbk In Workbooks ' ' ーーーー実行前から開いていたブック名が転記元ファイル名一覧に含まれ、 ' ' ーーーーそのブックが指定のフォルダに存在するならば If InStr(sBuf, vbCrLf & oWbk.Name) Then If oWbk.Path = sDir Then If Not oWbk.Saved Then If MsgBox("処理の続行には上書き保存する必要あり" & vbLf & vbTab & oWbk.Name & vbLf & "続行?", vbYesNo) = vbYes Then oWbk.Save Else MsgBox "中止": Exit Sub End If End If Else MsgBox "転記元に指定したブックと同名ブックが開いているので中止": Exit Sub End If End If Next ' ' ーーーーーーーーー ' ' ファイル名一覧の、前後のCrLfトル sBuf = Mid$(sBuf, 3, Len(sBuf) - 4) ' ' ーーーーーーーーー ' ' ファイル名一覧から、転記元ブック名の配列 Dim arrFn() As String ' 転記元ブック名の配列 arrFn() = Split(sBuf, vbCrLf) ' ' ーーーーーーーーー ' ' 転記元ブック名の配列を総当りで、転記 Dim wsPrint As Worksheet ' 転記先シート Dim wsLog As Worksheet ' 開けなかったブック名を出力するシート Dim wsSrc As Worksheet ' 各転記元シート Dim sFile As String ' 転記元の各ブック名 Dim i As Long ' ループ用 Dim cnT As Long ' 正しく出力できた数 Dim cnF As Long ' 転記元ブックをOpen出来なかった数 Dim flgO As Boolean ' 各ブックが実行前から開いていたかどうか Set wsPrint = ThisWorkbook.Sheets(1) ' 転記先シート Set wsLog = ThisWorkbook.Sheets(3) ' 開けなかったブック名を出力するシート Application.ScreenUpdating = False ' 画面更新を一時停止 Application.EnableEvents = False ' イベントを一時抑止 cnT = 0: cnF = 0 For i = 0 To UBound(arrFn()) flgO = False Set wsSrc = Nothing sFile = arrFn(i) ' ' ーーーー転記元ブック開いている、と仮定して ' ' ーーーー転記元シートにアクセスしてみる On Error Resume Next Set wsSrc = Workbooks(sFile).Worksheets(1) On Error GoTo 0 ' ' ーーーー転記元シートへのアクセスに失敗していたならば If wsSrc Is Nothing Then ' ' ーーーー転記元ブックはパスワード指定なしで開ける、と仮定して ' ' ーーーー転記元シートにアクセスしてみる On Error Resume Next Set wsSrc = Workbooks.Open(sDir & "\" & sFile, Password:="", UpdateLinks:=False, ReadOnly:=True).Worksheets(1) On Error GoTo 0 Else ' ' ーーーー転記元シートへのアクセスに成功していたならば ' ' ーーーー転記元ブックは実行前から開いている flgO = True End If ' ' ーーーー転記元シートへのアクセスに失敗していたならば If wsSrc Is Nothing Then cnF = cnF + 1 ' ' ーーーー開けなかったブック名を出力 wsLog.Cells(cnF, 1).Value = sFile Else ' ' ーーーー転記元シートへのアクセスに成功していたならば With wsSrc ' 転記元シート cnT = cnT + 1 ' ' B2の値、転記元の各ブック名、転記元の各シート名、を纏めて出力 wsPrint.Cells(cnT, "A").Resize(, 3).Value = Array(.Range("B2"), .Parent.Name, .Name) ' ' 元々開いていなかったブックならば保存せず閉じる If Not flgO Then .Parent.Close False End With End If Next i Set wsPrint = Nothing: Set wsLog = Nothing: Set wsSrc = Nothing Application.EnableEvents = True ' イベント抑止を解除 Application.ScreenUpdating = True ' 画面更新停止を解除 MsgBox UBound(arrFn()) + 1 & "個中 " & cnT & "個取得 " & cnF & "個失敗" Erase arrFn() End Sub
関連するQ&A
- エクセルVBAでBOOKに読み取りパスワード設定
エクセル2013です。 以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。 しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか?教えてください。 Sub TEST01() Dim myfdr As String, fname As String Dim mb As Workbook, wb As Workbook Dim n As Long With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定 If .Show = True Then myfdr = .SelectedItems(1) Else MsgBox "キャンセルします。" Exit Sub End If End With Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索 n = 2 Do Until fname = Empty '全て検索 Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 With mb.Sheets("Sheet1") '転記 .Cells(n, "B").Value = wb.FullName .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value End With n = n + 1 'カウント Application.DisplayAlerts = False wb.SaveAs Filename:=wb.FullName, Password:="emaxemax" wb.Close Application.DisplayAlerts = True fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す MsgBox n - 2 & "件処理しましました。" End Sub
- ベストアンサー
- Excel(エクセル)
- エクセルVBAで別BOOKに「名前の定義」のCopy
前からあったエクセルのファイルのどこかが壊れたらしく、ときどき作業中に突然エラーとなってエクセル自体が落ちてしまうので、BOOKの複製では意味がないと考え、同じ内容のものを別BOOKに再作成するマクロを以下のとおり作ってみました。(新規作成のBOOKにこのマクロを貼ります) これで、VBAのモジュールを除き、再作成できたのですが、どういうわけか「名前の定義」を行なったセル範囲の一部が反映されません。 調べてみると、他のセルから参照されていない「名前の定義」がすっぽり抜け落ちるようにも思えるのですが、この理解であっているでしょうか? 他のセルから参照していなくとも、マクロで参照しているので抜け落ちるのは困ります。 どうすれば、すべての「名前の定義」が再作成されるでしょうか? Sub Book_Copy() Dim fn As String Dim wb1 As Workbook, wb2 As Workbook Dim ans As Integer, i As Integer Dim nm As Name Dim sh As Worksheet fn = Application.GetOpenFilename("エクセル ファイル (*.xls), *.xls") If fn = "False" Then Exit Sub Application.EnableEvents = False Set wb1 = Workbooks.Open(Filename:=fn, UpdateLinks:=1) Set wb2 = ThisWorkbook ans = MsgBox(wb1.Name & "を " & wb2.Name & " へCopyしますか?", vbYesNo + vbQuestion) If ans = vbNo Then Exit Sub For Each nm In wb2.Names nm.Delete Next nm For Each sh In wb1.Worksheets sh.Cells.Copy i = i + 1 If wb2.Worksheets.Count = i Then wb2.Worksheets.Add After:=Worksheets(i) Application.DisplayAlerts = False wb2.Activate wb2.Worksheets(i).Activate wb2.Worksheets(i).Cells.Select ActiveSheet.Paste wb2.Worksheets(i).Name = sh.Name Application.DisplayAlerts = True Application.CutCopyMode = False End If Next sh wb1.Close (False) Application.EnableEvents = True ActiveWorkbook.ChangeLink Name:=fn, NewName:=wb2.Name, Type:=xlExcelLinks Set wb1 = Nothing Set wb2 = Nothing End Sub
- ベストアンサー
- オフィス系ソフト
- VBAでBOOKを開かずにプロパティ変更
エクセル2013です。 特定のフォルダ内のエクセルのBOOKのプロパティの作成者をすべて変えようと思います。 いろいろ試して、以下のコードでできるようになりました。 しかし、下記のコードではいちいちファイルを開かなくてはなりませんのでサイズが大きかったり、数が多いと結構時間がかかります。 手作業でファイルのプロパティを変えるときは、エクスプローラで右クリックすれば開かなくとも簡単にできます。VBAでもファイルを開かずにプロパティを変更するにはどうすればよいのでしょうか?お教えいただければ幸いです。 Sub TEST20190710() Dim myFdr As String, fnm As String Dim wb As Workbook Dim n As Long Const NEW_AUTHOR As String = "emaxemax" Application.ScreenUpdating = False Application.EnableEvents = False myFdr = "C:\Users\User\Documents\TEST01" fnm = Dir(myFdr & "\*.xls?") Do Until fnm = Empty Set wb = Workbooks.Open(myFdr & "\" & fnm) Application.DisplayAlerts = False wb.BuiltinDocumentProperties("Author").Value = NEW_AUTHOR wb.Close SaveChanges:=True Application.DisplayAlerts = True n = n + 1 fnm = Dir Loop Application.ScreenUpdating = True Application.EnableEvents = True MsgBox n & "件のブックを処理しましました。", vbInformation End Sub
- ベストアンサー
- Excel(エクセル)
- エクセルVBAで、ある条件の時
お世話になります。 エクセルVBAで次のようなことをしたいのですが方法を教えてください。 formフォルダにあるすべてのファイルについて、A1セルが「0」でないとき、 A4:B7及びA9:B12の中で日付が入っている行の日付と内容を、ActiveWorksheetのB列、C列にレコードとして取り出したいのです。 (A列はナンバリングになります) --------formフォルダの中にあるブック--------- A B 1 23 2 3 日付 内容 'この行は固定です 4 5/13 あああ 5 5/17 いいい 6 7 8 日付 内容 'この行は固定です 9 5/16 ううう 10 5/12 えええ 11 12 5/10 おおお ---ThisWorkbook(前に助けていただいたコードです)--- Sub data_torikomi2() Dim wb As Workbook Dim Fn As String Dim myPath As String Dim dbBkSh As Worksheet Dim i As Long For Each wb In Workbooks If wb.Name <> ThisWorkbook.Name And _ InStr(1, wb.FullName, "form\", 1) > 0 Then 'formを検索 wb.Close '閉じる End If Next wb myPath = ThisWorkbook.Path & "\" Set dbBkSh = ThisWorkbook.Worksheets("一覧表") Range("4:1000").Clear '全データ削除 Fn = Dir(myPath & "form\*.xls") i = 1 '画面のちらつきを抑える Application.ScreenUpdating = False Do Until Fn = "" If Fn <> ThisWorkbook.Name Then With Workbooks.Open(myPath & "form\" & Fn, , True) dbBkSh.Range("A3").Offset(i, 0).Value = i 【★たぶんこの部分に入るものです★】 .Close False i = i + 1 End With End If Fn = Dir() Loop Application.ScreenUpdating = True Set dbBkSh = Nothing End Sub ご教示よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 複数シートをブックにするマクロを応用して。。
1ブック内にyymmdd(日付)シートが多数あり、それを月別yymmごとブックを作成するマクロです。 これは以前、回答して頂いた「n-jun」さんの構文です(n-junさん、重宝しています、感謝!) Private Sub CommandButton1_Click() Dim myDic As Object Dim wb1 As Workbook Dim wb As Workbook Dim ws As Worksheet Dim sh As Worksheet Dim myKey Set myDic = CreateObject("Scripting.Dictionary") Set wb1 = ThisWorkbook Application.ScreenUpdating = False For Each sh In wb1.Worksheets myDic(Left(sh.Name, 4) & "_") = Empty Next For Each myKey In myDic.keys For Each sh In wb1.Worksheets If InStr(sh.Name, Left(myKey, 4)) > 0 Then If wb Is Nothing Then wb1.Worksheets(sh.Name).Copy Set wb = ActiveWorkbook Else wb1.Worksheets(sh.Name).Copy after:=wb.Sheets(wb.Sheets.Count) End If End If Next Application.DisplayAlerts = False wb.SaveAs Filename:="C:\仕事\月別" & "\" & Left(myKey, 4) & ".xls" wb.Close Set wb = Nothing Application.DisplayAlerts = True Next Application.ScreenUpdating = True Set myDic = Nothing Worksheets("main").Activate MsgBox "出力完了" End Sub 実は、これをフォルダ内のブックの場合は? として応用ができないか悩んでいます。 つまり、フォルダ内にyymmddブックが多数あり、 これを月別yymmとして、それぞれまとめたいのです。 Set wb1 = ThisWorkbookの箇所が、 フォルダ内のブック指定になると思うのですが、 下記コードでどうなんでしょうか?動きません。 myfdr = "C:\仕事\月別" fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 Set wb1 = Workbooks.Open(myfdr & "\" & fname) 変更箇所、アドバイス頂ければ助かります。お願いします
- ベストアンサー
- オフィス系ソフト
- 【VBA】複数のブックを1つのシートにまとめる
あるフォルダ内に複数のブックが入っており、新しいブックに1シートでまとめようとしております。 フィルターを使用すればよいのかもしれませんが、マクロを使用したいです。 (1)全て同じフォーマットである (2)全てA17から数値が入力されているので、16行目まではフォーマットを残し、A17行目以降K列までをコピーして結合したい Sub 結合() '結合したいファイルがあるフォルダの場所 cドライブなら "C:\test\" Const Fol As String = "C:\test\" Dim Fn Dim NewFile As Workbook Dim Wb As Workbook Dim Ws1 As Worksheet Dim R As Range Set NewFile = Workbooks.Add Set Ws1 = NewFile.Worksheets(1) Set R = Ws1.Range("A17") Fn = Dir(Fol, vbNormal) Do Until Fn = "" Set Wb = Workbooks.Open(Fol & Fn) 'ワークシート1をコピーする場合は Wb.Worksheets(1) Set Ws1 = Wb.Worksheets(1) 'タイトル行を設定 If ck = False Then For cnt = 1 To 4 Wb.Worksheets(cnt).Range("A1:J16").Copy Destination:=NewFile.Worksheets(cnt).Range("A1") Next cnt ck = True End If For cnt = 1 To 4 Set Ws1 = NewFile.Worksheets(cnt) Set Ws2 = Wb.Worksheets(cnt) R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1 With Ws2 End With Next 'A17行目からコピーして結合する(→本当はA17行目~K列までを反映したい) Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R If R.Offset(1).Value = "" Then Set R = R.Offset(1) Else Set R = R.End(xlDown).Offset(1) End If Wb.Close 'Debug.Print Fn Fn = Dir Loop Set R = Nothing Set Ws1 = Nothing: Set Ws2 = Nothing Set Wb = Nothing: Set NewFile = Nothing End Sub マクロは触ったことない初心者でグーグル検索をしながら作ってみました。 一応実行するとエラーは出ないのですが、結合されたリストが飛び飛びで、理由がわかりません。 どなたかおわかりになりますでしょうか・・・。
- ベストアンサー
- Visual Basic
- エクセルVBAでファイル作成
エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。 しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。 処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか? 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。 よろしくお願いします。 Option Explicit Sub データ分割転記() Dim myPth As String, fname As String Dim myRng As Range, myC As Range Dim i As Long, x As Long Dim wb(2) As Workbook Dim ws As Worksheet Dim t As Single t = Timer Set wb(0) = ThisWorkbook myPth = wb(0).Path With wb(0).Sheets("Key") Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData End With For Each myC In myRng Application.EnableEvents = False Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm") Set ws = wb(1).Sheets("List") With wb(0).Sheets("DATA") .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9") .ShowAllData End With With ws x = .Cells(Rows.Count, "A").End(xlUp).Row myC.Offset(, 2).Value = x '行数確認 .Range("A9").Value = 1 If x > 9 Then .Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番 End If End With wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm" wb(1).Close (False) Application.EnableEvents = True i = i + 1 Next MsgBox i & "件を完了" _ & vbCrLf & Timer - t & " Sec." End Sub *Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。
- ベストアンサー
- Excel(エクセル)
- エクセルのVBAの記述について
VBAの記述についてなのですが、 Sub filter() Dim gyo As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Set ws1 = Worksheets("データ") Set ws2 = Worksheets("チーム") Application.ScreenUpdating = False ws2.Range("A4:BH30").Clear gyo = ws1.Range("A65536").End(xlUp).Row ws1.Activate With ws1.Range(Cells(4, 1), Cells(gyo, 6)) .AutoFilter Field:=1, Criteria1:="A" .SpecialCells(xlCellTypeVisible).Copy ws2.Range("A4") Selection.AutoFilter End With Application.ScreenUpdating = True End Sub ならプログラムははしるのですが、 14行目を .SpecialCells(xlCellTypeVisible).Copy ws2.Range(Cells(4, 1)) だと 「実行時エラー 1004 Rangeメソッドは失敗しました Worksheet オブジェクト」 とでるのですが、出来ないのでしょうか? Cells(4, 1)の1のところを変数にして変えていきたいのですが、よい方法はありますか。 よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBA フォルダ内のどんなシート名であっても読み込みたい
フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub
- ベストアンサー
- オフィス系ソフト
- Excel VBAについて教えて下さい。
00というブックとテストというブックがあります。 00のデータを並び替え、一部変更し、テストのシート3へ貼付けを行いたいのですが、 うまく作動してくれません。以下に現在のコードを記載しましたので、ご指摘いただければと思います。 やりたいことは 1.ブック”00”のシート00にて条件がF列が0、E列がHでソートをかけます。 2.E列のHをすべて数字の1に変更します。 3.今度は別の条件、F列が1、E列がH、D列が1でソートをかけます。 4.E列のHをすべて消去します。 5.すべて表示させA列からE列までのデータを、テストのシート3へ貼付けをします。 コピー&ペーストは上手くいくのですが、肝心のソート+文字の変更+消去が出来ていません。 ネットを見ながら書いたコードで、VBAを勉強中です。 よろしくお願いします。 あと、この作業の前にブック00のB列にて昇順のソートをかけるというコードを追加したいのですが、 それについても教えていただけるとうれしいです。 よろしくお願い致します。 Private Sub Worksheet_Activate() Dim wb1 As Workbook Dim wb2 As Workbook Dim i As Long Application.ScreenUpdating = False Set wb1 = ActiveWorkbook Set wb2 = Workbooks.Open("C:\Documents and Settings\デスクトップ\メモ\00.xls", ReadOnly:=True) With wb2.Worksheets("00").Range("A1").CurrentRegion .AutoFilter .AutoFilter Field:=6, Criteria1:="=" & "0", Operator:=xlAnd .AutoFilter Field:=5, Criteria1:="=" & "H", Operator:=xlAnd .AutoFilter x = .Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To x If Cells(i, 5) = "H" Then Cells(i, 5) = Replace(Cells(i, 5), "H", "1") End If Next i With wb2.Worksheets("00").Range("A1").CurrentRegion .AutoFilter .AutoFilter Field:=6, Criteria1:="=" & "0", Operator:=xlAnd .AutoFilter Field:=5, Criteria1:="=" & "H", Operator:=xlAnd .AutoFilter Field:=4, Criteria1:="=" & "1", Operator:=xlAnd .AutoFilter x = .Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To x If Cells(i, 5) = "H" Then Cells(i, 5) = Replace(Cells(i, 5), "H", " ") End If Next i wb2.Sheets("00").Range("B1", .Cells(Rows.Count, 5).End(xlUp)).Copy wb1.Sheets("Sheet3").Range("K3").PasteSpecial wb2.Close False Range("A1").Select Application.ScreenUpdating = True End With End With End Sub
- ベストアンサー
- オフィス系ソフト
お礼
cj_moverさん、何度もありがとうございます。 > 転記元となるべきブックが実行前に既に開いていたとして、そのブックに未保存データがある場合、どうしようか、とか。 未保存データのようなことはまったく想定していませんでした。 危うくとんでもないものを作ってしまうところでした。 そのような場合の対応を私が決めるわけにもいかないので、とりあえずは For Each wb(1) In Workbooks If wb(1).Name <> ThisWorkbook.Name And Not StrConv(wb(1).Name, vbUpperCase) Like "PERSONAL.XLS*" Then MsgBox "他のBookが開いているようです。" _ & vbCrLf & "お手数ですが、一旦他のBOOKを閉じてから開始してください。", vbCritical Exit Sub End If Next wb(1) で、逃げることにします。(個人用マクロBOOKの存在を考慮したつもりです) ご指導有難うございました。