[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA全体実行をすると途中で止まってしまう』（ピノ）
いつもお世話になっております。
VBAでステップ実行をすると、処理ができるのに、
全体実行をすると、途中で処理が終わってしまいます。
エラーメッセージは何もでません。
詳細は、下部に全構文を記載させていただきました。
以下１までは処理ができていて、
２の検索ループ以降処理ができなくなってしまいます。
要因とがわかれば教えていただけたら助かります。
１
Range("AB:AB").Copy
Range("AB:AB").PasteSpecial Paste:=xlPasteValues
２
'▼3行目～最終行目に#N/Aがあった場合に該当行の4列目を黄色塗り
Dim rngFind As Range
Dim fAddress As String
Set rngFind = Range("AB3:AB" & i).Find(what:="#N/A", _
LookIn:=xlValues, _
lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False)
'見つからなかったら ※見つかったら…If Not rngFind Is Nothing Then
If rngFind Is Nothing Then
＜全文＞
Sub テータ加工2_05()
Application.DisplayAlerts = False
'On Error Resume Next
'<<<<<冷凍・チルドデータをドッキング>>>>>
Workbooks("5_完成（05_冷凍）.xlsx").Activate
'コピー＿チルドデータを範囲コピー（可変）
With Workbooks("5_完成（05_チルド）.xlsx").Worksheets(1)
'A1の１つ下行A2から最後のセルまでを範囲コピー
.Range("A2", .Cells.SpecialCells(xlCellTypeLastCell)).Offset(1).Copy
End With
'貼付け＿冷凍データ最終行に貼付け
Workbooks("5_完成（05_冷凍）.xlsx").Activate
'A列最終行の1つ下行を選択→貼付け
With Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Select
End With
ActiveSheet.Paste
Range("A1").Select
'▼別名保存
Const MyPath As String = "C:\Users\mi\Desktop\C026_週間発注表作成\1_営業確認用"
'保存しないで閉じる
Workbooks("5_完成（05_チルド）.xlsx").Close False
Dim 開始日 As String, 終了日 As String
'週間発注日付をファイル名に設定
開始日 = Format(Date + 2, "yyyymmdd")
終了日 = Format(Date + 8, "yyyymmdd")
ActiveWorkbook.SaveAs Filename:=MyPath & "\" & 開始日 & "-" & 終了日 & "週間発注表(05).xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'一時ファイルを開く
Workbooks.Open Filename:="C:\Users\mi\Desktop\C026_週間発注表作成\4_RPA作業用\一時ファイル.xlsx"
Dim 一時ファイル As Workbook
Set 一時ファイル = ActiveWorkbook
'<<<<新規商品が無いか確認>>>
'▼1週間前のファイルを開く
Const BackPath As String = "C:\Users\mi\Desktop\C026_週間発注表作成\1_営業確認用\バックナンバー"
Dim 開始日1 As String, 終了日1 As String
開始日1 = Format(Date - 5, "yyyymmdd")
終了日1 = Format(Date + 1, "yyyymmdd")
Workbooks.Open Filename:=BackPath & "\" & 開始日1 & "-" & 終了日1 & "週間発注表(05).xlsx"
Columns("A:B").Copy
一時ファイル.Worksheets(1).Paste
'保存しないで閉じる
Workbooks(開始日1 & "-" & 終了日1 & "週間発注表(05).xlsx").Close False
'▼2週間前のファイルを開く
Dim 開始日2 As String, 終了日2 As String
開始日2 = Format(Date - 12, "yyyymmdd")
終了日2 = Format(Date - 6, "yyyymmdd")
Workbooks.Open Filename:=BackPath & "\" & 開始日2 & "-" & 終了日2 & "週間発注表(05).xlsx"
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("A3:B" & i).Copy
'最終行の1行下に貼付け
一時ファイル.Activate
With Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Select
End With
ActiveSheet.Paste
'保存しないで閉じる
Workbooks(開始日2 & "-" & 終了日2 & "週間発注表(05).xlsx").Close False
'▼3週間前のファイルを開く
Dim 開始日3 As String, 終了日3 As String
開始日3 = Format(Date - 19, "yyyymmdd")
終了日3 = Format(Date - 13, "yyyymmdd")
Workbooks.Open Filename:=BackPath & "\" & 開始日3 & "-" & 終了日3 & "週間発注表(05).xlsx"
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("A3:B" & i).Copy
'最終行の1行下に貼付け
一時ファイル.Activate
With Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Select
End With
ActiveSheet.Paste
'保存しないで閉じる
Workbooks(開始日3 & "-" & 終了日3 & "週間発注表(05).xlsx").Close False
'▼4週間前のファイルを開く
Dim 開始日4 As String, 終了日4 As String
開始日4 = Format(Date - 26, "yyyymmdd")
終了日4 = Format(Date - 20, "yyyymmdd")
Workbooks.Open Filename:=BackPath & "\" & 開始日4 & "-" & 終了日4 & "週間発注表(05).xlsx"
i = Cells(Rows.Count, 1).End(xlUp).Row
Range("A3:B" & i).Copy
'最終行の1行下に貼付け
一時ファイル.Activate
With Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Select
End With
ActiveSheet.Paste
'保存しないで閉じる
Workbooks(開始日4 & "-" & 終了日4 & "週間発注表(05).xlsx").Close False
Workbooks(開始日 & "-" & 終了日 & "週間発注表(05).xlsx").Activate
i = Cells(Rows.Count, 1).End(xlUp).Row
'▼VLOOKUP
Range("AB3") = "=VLOOKUP(B3,'[一時ファイル.xlsx]Sheet1'!B:B,1,0)"
'フィルダウン
Range("AB3:AB" & i).FillDown
'値貼り付け
Range("AB:AB").Copy
Range("AB:AB").PasteSpecial Paste:=xlPasteValues
'▼3行目～最終行目に#N/Aがあった場合に該当行の4列目を黄色塗り
Dim rngFind As Range
Dim fAddress As String
Set rngFind = Range("AB3:AB" & i).Find(what:="#N/A", _
LookIn:=xlValues, _
lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False)
'見つからなかったら ※見つかったら…If Not rngFind Is Nothing Then
If rngFind Is Nothing Then
Exit Sub
Else
'見つかったら
If Not rngFind Is Nothing Then
rngFind.Offset(, -24).Interior.ColorIndex = 6
End If
fAddress = rngFind.Address
Do
rngFind.Offset(, -24).Interior.ColorIndex = 6
Set rngFind = Range("AB3:AB" & i).FindNext(rngFind)
If rngFind Is Nothing Then Exit Do
Loop While fAddress <> rngFind.Address
End If
'AB列クリア
Range("AB3:AB" & i).Clear
'不要倉庫列削除
Columns("U:V").Delete
'<<<<<最終保存して閉じる>>>>>
Workbooks(開始日 & "-" & 終了日 & "週間発注表(05).xlsx").Close True
'保存しないで閉じる
一時ファイル.Close False
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
エラーが無かったから、単純に抜けちゃってるだけではないですか？
＞ '見つからなかったら ※見つかったら…If Not rngFind Is Nothing Then ＞ If rngFind Is Nothing Then ＞ Exit Sub ~~~~~~~~~
（稲葉） 2020/08/08(土) 16:17
少しコードまとめてみました。 テスト環境が無いのでテストまではしておりませんが、少し眺めてみてください。 テストする場合は、バックアップを取ってから試してみてください。
Sub テータ加工2_05()
'On Error Resume Next
'週間発注日付をファイル名に設定
Const MyPath As String = "C:\Users\mi\Desktop\C026_週間発注表作成\1_営業確認用" '今週のブックの保存先
Const BackPath As String = "C:\Users\mi\Desktop\C026_週間発注表作成\1_営業確認用\バックナンバー"
Dim チルドブック As Workbook
Dim 今週のブック As Workbook
Dim 一時ファイル As Workbook
Dim 開始日 As String, 終了日 As String '週間発注保存用
Dim i As Long
Dim rngFind As Range '#N/A検索用
Dim fAddress As String '#N/A検索ループ用
Dim n日前 As Long 'n週間前のループ用
Dim BNファイル名 As String 'バックナンバーのファイル名
Application.DisplayAlerts = False
'//冷凍・チルドデータをドッキング// ここから
'コピー＿チルドデータを範囲コピー（可変）
Set チルドブック = Workbooks("5_完成（05_チルド）.xlsx")
With チルドブック.Sheets(1)
'A1の１つ下行A2から最後のセルまでを範囲コピー
.Range("A2", .Cells.SpecialCells(xlCellTypeLastCell)).Offset(1).Copy
End With
'A列最終行の1つ下行を選択→貼付け
'★シート名を指定したほうが良いかと。
With Workbooks("5_完成（05_冷凍）.xlsx")
.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlAll
'~~~~~~~↑~~~~~~~~
'★アクティブワークブック・シートだと曖昧なので、ブックとシートは明記する
開始日 = Format$(Date + 2, "yyyymmdd")
終了日 = Format$(Date + 8, "yyyymmdd")
.SaveAs Filename:=MyPath & "\" & 開始日 & "-" & 終了日 & "週間発注表(05).xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Set 今週のブック = Workbooks(.Name)
End With
'保存しないで閉じる
チルドブック.Close False
'//冷凍・チルドデータをドッキング// ここまで
'//新規商品が無いか確認// ここから
'一時ファイルを開く
Set 一時ファイル = Workbooks.Open(Filename:="C:\Users\mi\Desktop\C026_週間発注表作成\4_RPA作業用\一時ファイル.xlsx")
For n日前 = 1 To -20 Step -7
BNファイル名 = BackPath & "\" & Format$(Date - n日前 - 6, "yyyymmdd") & "-" & Format$(Date - n日前, "yyyymmdd") & "週間発注表(05).xlsx"
'▼1週間前のファイルを開く
With Workbooks.Open(BNファイル名, ReadOnly:=True)
With Sheets(1)
If n日前 = 1 Then
'1週間前なら、AB列をコピー
.Columns("A:B").Copy 一時ファイル.Sheets(1)
Else
'2週間前以前なら、最終行を一時ファイルにコピー
.Range("A3:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy
'最終行の1行下に貼付け
With 一時ファイル.Sheets(1)
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlAll
End With
End If
End With
'保存しないで閉じる
.Close False
End With
Next n日前
With 今週のブック
With .Sheets(1) 'シートを明記
i = .Cells(Rows.Count, 1).End(xlUp).Row
'▼VLOOKUP
.Range("AB3:AB" & i).Formula = "=VLOOKUP(B3,'[一時ファイル.xlsx]Sheet1'!B:B,1,0)"
'値貼り付け
.Range("AB3:AB" & i).Value = .Range("AB3:AB" & i).Value
'▼3行目～最終行目に#N/Aがあった場合に該当行の4列目を黄色塗り
Set rngFind = .Range("AB3:AB" & i).Find(what:="#N/A", _
LookIn:=xlValues, _
lookat:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False)
If rngFind Is Nothing Then
'見つからなかったら何もしない
'Exit Sub
Else
'見つかったら
rngFind.Offset(, -24).Interior.ColorIndex = 6
fAddress = rngFind.Address
Do
rngFind.Offset(, -24).Interior.ColorIndex = 6
Set rngFind = .Range("AB3:AB" & i).FindNext(rngFind)
If rngFind Is Nothing Then Exit Do
Loop While fAddress <> rngFind.Address
End If
'AB列クリア
.Range("AB3:AB" & i).Clear
'不要倉庫列削除
.Columns("U:V").Delete
End With
一時ファイル.Close False
.Close True
End With
'//新規商品が無いか確認// ここまで
Application.DisplayAlerts = True
End Sub
（稲葉） 2020/08/08(土) 17:19
訂正
＞.Columns("A:B").Copy 一時ファイル.Sheets(1)
.Columns("A:B").Copy
一時ファイル.Sheets(1).Paste
（稲葉） 2020/08/08(土) 17:21
構文までまとめて頂き、大変有難う御座います…。
自分でも不要な構文書いてる気がする…と思いながら、短縮の方法がわからなかったので、そのままにしていました。
いただいた構文で、勉強させていただきます！
本当に有難うございます！
（ピノ） 2020/08/08(土) 17:47
最後の一文は現状のコードにもいれておいた方がいいです Application.DisplayAlerts = True Falseのままエクセル使っていると、閉じたときの「保存しますか？」 のようなダイヤログも出なくなっちゃいます （稲葉） 2020/08/08(土) 18:26
また、纏めていただいた構文を確認させてもらっていますが、
コメントの書き方や過去ファイルをForでループさせる方法、とても勉強になりました。
色々とありがとうございます。
（ピノ） 2020/08/08(土) 18:37
■１
＞見つからなかったら…の後のExit Sub がいらなかったんですね！！
ステップ実行をしているなら、原因自体はご自身で確認できたのではないでしょうか？
また、本当に"何もしない"（プロシージャを抜けることもしない）のであれば、そもそも記述しなくてよいでしょう。
Sub 実験1()
Stop
Dim tmp As Range
If tmp Is Nothing Then
'なにもしない
Else
MsgBox "テキトー"
End If
End Sub
'-------------------------------------------
Sub 実験2()
Stop
Dim tmp As Range
If Not tmp Is Nothing Then
MsgBox "テキトー"
End If
End Sub
■２
[[20200806235620]]の時にも思いましたが、本当に「本日」（マクロを実行した日）でよいのですか？
週間発注表なんて書いてあるところから想像するに、1週間単位の処理じゃないんでしょうか。
休日なんかで、締め日？にマクロを実行できない場合に困ったことになりませんか？
私が作るなら処理日を別途入力するなり、マクロを実行した日がどの週に属するのか判定するなどの処理を入れると思います。
■３
コメントアウトしてますが、冒頭の「On Error Resume Next」は何用ですか？
エラーが発生するからよくわからないけど飛ばしてました～なんてことであれば、やめたほうがいいです。
"一知的に"エラーを無視したい場合は、その部分に記述すべきです。
■４
(1) VLOOKUPを使った数式を書き込む (2) 値貼り付けをする (3) "#N/A"を検索する (4) 見つかったら塗りつぶしをする (5) 作業用に使ったセルをクリアする
↑の部分は、↓のようにしてもよいとおもいます。
(1) VLOOKUPを使った数式を書き込む (2) エラー値になっているセルがあれば、塗りつぶしをする (3) セルをクリアする
よって、こんな感じでもOKじゃないでしょうか（元コードが読みづらかったので稲葉さんが整理されたコードをベースにしています。）
With 今週のブック
With .Sheets(1) 'シートを明記
i = .Cells(Rows.Count, 1).End(xlUp).Row
With .Range("AB3:AB" & i)
'▼数式を書き込む
.Formula = "=VLOOKUP(B3,'[一時ファイル.xlsx]Sheet1'!B:B,1,0)"
'▼一時的にエラーを無視してから（エラー値がなかった時の対策）、エラー値になっているセルの色の塗りつぶし色を設定
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, xlErrors).Offset(, -24).Interior.ColorIndex = 6
On Error GoTo 0
'▼クリアするなら値貼付けは要らない
.Clear
End With
End With
End With
■５
問題があるわけではないですが、↓についてどの環境でも必ず同じ色にはならないことは理解されておいたほうがよいです。
.Interior.ColorIndex = 6
【参考】
http://officetanaka.net/excel/vba/graph/24.htm
■６
コピーする部分についても、↓のような感じでもよいとおもいます。
（コメントつけましたが、タイプミスと思われる部分があったので直しています。正しければ元に戻してください）
Dim チルドブック As Workbook
Dim 今週のブック As Workbook
Dim コピー範囲 As Range
Set チルドブック = Workbooks("5_完成（05_チルド）.xlsx")
Set 今週のブック = Workbooks("5_完成（05_冷凍）.xlsx")
With チルドブック.Sheets(1)
'// Offset(1)はいつものタイプミスでは？「A"1"」だったら分かりますが・・・
Set コピー範囲 = .Range("A2", .Cells.SpecialCells(xlCellTypeLastCell))
End With
コピー範囲.Copy 今週のブック.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1)
今週のブック.SaveAs _
Filename:=MyPath & "\" & Format$(Date + 2, "yyyymmdd") & "-" & Format$(Date + 8, "yyyymmdd") & "週間発注表(05).xlsx", _
FileFormat:=xlOpenXMLWorkbook
（もこな２ ） 2020/08/11(火) 03:21
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.