[[20230127114939]] 『VBA条件分岐がうまくでいない』(トリちゃん) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『VBA条件分岐がうまくでいない』(トリちゃん)

こんにちは。
条件分岐がうまくできず困っております。
対象シートがない場合、未完了とセルに入力したいです。
対象シートがあった場合、一度は完了と記入されますが、その後未完了と上書きされてしまい、C列すべて未完了と記入されてしまいます。
どなたかご教授ください。
よろしくお願いいたします。

Sub test()

Dim wbList As Workbook, wbDel As Workbook, wbMaster As Workbook
Dim ws As Worksheet, wsList As Worksheet, wsDel As Worksheet
Dim Path01 As String, Path02 As String, TargetName As String, C As String
Dim LastRow As Long, i As Long
Dim targetSheet As Variant

Set wbMaster = ThisWorkbook

'Ph.G対象者リストを開く
MsgBox "ALL_Ph.G対象者リストを選んでください"
Path01 = Application.GetOpenFilename
Set wbList = Workbooks.Open(Path01)
Set wsList = wbList.Worksheets("※編集禁止※ALL(数式あり)")

'代理店配信シートを開く
MsgBox "代理店配信用シートを選んでください"
Path02 = Application.GetOpenFilename
Set wbDel = Workbooks.Open(Path02)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'代理店マスタを元に、配信用シートを特定し、Ph.G対象者リストからコピー&ペースト
With wbMaster.Worksheets(1)
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For Each targetSheet In wbDel.Worksheets

    For i = 2 To LastRow
        TargetName = .Cells(i, "B").Value
        If targetSheet.Name = TargetName Then
            Set wsDel = wbDel.Worksheets(TargetName)
            wsDel.Range("A4:E" & wsDel.Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
            wsList.Range("A1").AutoFilter 2, "〇"
            wsList.Range("A1").AutoFilter 30, TargetName
            wsList.Range("J5:N" & wsList.Cells(Rows.Count, "N").End(xlUp).Row).Copy
            wbDel.Worksheets(TargetName).Range("A4").PasteSpecial xlPasteValues
            .Cells(i, "C").Value = "完了"
            Debug.Print C
        Else
            .Cells(i, "C").Value = "未完了"
            Debug.Print C
        End If
    Next i
Next
End With

Application.CutCopyMode = False
wbList.Close SaveChanges:=False

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

< 使用 Excel:Microsoft365、使用 OS:Windows11 >


 条件分岐じゃなくて、ループが二重になってるだけじゃないかなぁ
 For i = 2 To LastRow
     For Each targetSheet In wbDel.Worksheets
 テスト環境も構築できてないから、ぶっつけになるけどステップ実行で様子見てもらえます?

    Option Explicit

    Sub test()
        Dim wbList As Workbook, wbDel As Workbook, wbMaster As Workbook
        Dim ws As Worksheet, wsList As Worksheet, wsDel As Worksheet
        Dim Path01 As String, Path02 As String, TargetName As String
        Dim LastRow As Long, i As Long
        Set wbMaster = ThisWorkbook

        'Ph.G対象者リストを開く
        MsgBox "ALL_Ph.G対象者リストを選んでください"
        Path01 = Application.GetOpenFilename
        Set wbList = Workbooks.Open(Path01)
        Set wsList = wbList.Worksheets("※編集禁止※ALL(数式あり)")

        '代理店配信シートを開く
        MsgBox "代理店配信用シートを選んでください"
        Path02 = Application.GetOpenFilename
        Set wbDel = Workbooks.Open(Path02)

        '代理店マスタを元に、配信用シートを特定し、Ph.G対象者リストからコピー&ペースト
        Set ws = wbMaster.Worksheets(1)
        LastRow = .Cells(Rows.Count, "B").End(xlUp).Row

        Application.ScreenUpdating = False

        'マスタシートのB列を2行目からループ処理
        For i = 2 To LastRow
            Stop '★ステップ実行してください。
            '対象者をマスターシートから変数に入れる
            TargetName = ws.Cells(i, "B").Value

            'wsDELに対象者のシートがあるかチェックし、シートがあれば処理を続ける
            wbDel.Activate
            If Evaluate("ISREF(" & TargetName & "!A1)") = True Then
                Set wsDel = wbDel.Worksheets(TargetName)
                wsDel.Range("A4:E" & wsDel.Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

                'フィルター結果のコピー
                With wsList
                    With .Range("A1")
                        .AutoFilter 2, "〇"
                        .AutoFilter 30, TargetName
                    End With
                    .Range("J5:N" & .Cells(Rows.Count, "N").End(xlUp).Row).Copy
                End With

                'wsDelに結果を書き込み
                wsDel.Range("A4").PasteSpecial xlPasteValues
                Application.CutCopyMode = False

                'マスターに結果を入力
                ws.Cells(i, "C").Value = "完了"
            Else
                ws.Cells(i, "C").Value = "未完了"
            End If
        Next i
        Application.ScreenUpdating = True

        'ブックを閉じる
        Application.DisplayAlerts = False
        wbList.Close SaveChanges:=False
        Application.DisplayAlerts = True
    End Sub

(稲葉) 2023/01/27(金) 12:40:48


適当すぎる案ですが

 .Range(.Cells(2, "C"),.Rells(LastRow,"C")).Value = "未完了"
 For Each targetSheet In wbDel.Worksheets
    For i = 2 To LastRow
        TargetName = .Cells(i, "B").Value
        If targetSheet.Name = TargetName Then
            Set wsDel = wbDel.Worksheets(TargetName)
            wsDel.Range("A4:E" & wsDel.Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
            wsList.Range("A1").AutoFilter 2, "〇"
            wsList.Range("A1").AutoFilter 30, TargetName
            wsList.Range("J5:N" & wsList.Cells(Rows.Count, "N").End(xlUp).Row).Copy
            wbDel.Worksheets(TargetName).Range("A4").PasteSpecial xlPasteValues
            .Cells(i, "C").Value = "完了"
            Debug.Print C
        End If
    Next i
 Next
(お邪魔します) 2023/01/27(金) 13:05:07

 >Set wsDel = wbDel.Worksheets(TargetName)

ループして探さなくても、ダメもとで変数に入れてみるといいかと。。。。

Option Explicit

Sub test()

    Dim wbBase As Workbook
    Dim wbResults As Workbook
    Dim rngList As Range
    Dim c As Range
    Dim wsTarget As Worksheet
    Dim a As String

    Set wbBase = Workbooks("???")
    Set wbResults = Workbooks("???")

    With ThisWorkbook.Worksheets(1)
        Set rngList = Application.Range(.Cells(2, "A"), .Cells(Cells.Count).End(xlUp), "A")
    End With

    For Each c In rngList
        On Error Resume Next
        Set wsTarget = wbResults.Worksheets(c.Value)  '★ダメ元で代入(エラーなら無視する)
        On Error GoTo 0

        If wsTarget Is Nothing Then
            a = "未完了"
        Else
            With wsTarget.UsedRange
                Intersect(.Cells, .Offset(3)).ClearContents
            End With

            With wbBase.Worksheets("※編集禁止※ALL(数式あり)").Range("A1").CurrentRegion
                .AutoFilter 2, "〇"
                .AutoFilter 30, TargetName
                .Offset(4).Copy
            End With
            wsTarget.Range("A4").PasteSpecial xlPasteValues
            a = "完了"
        End If

        c.Offset(, 2).Value = a
        set wsTarget = Nothing
    Next

    wbBase.Close
End Sub

(まっつわん) 2023/01/27(金) 14:01:01


出遅れた感がありますし、被っているところもありますが何点か。

■1
>対象シートがない場合、未完了とセルに入力したいです。
"対象シート"とは、どのブックのどのシートなのですか?
(どのように判定すればいいのですか)
(後に出てくる"配信用シート”のことですか?)

■2
>対象シートがあった場合、一度は完了と記入されますが、その後未完了と上書きされてしまい、
>C列すべて未完了と記入されてしまいます。

イメージする処理がわかりませんが、一旦完了となったらそこで処理終わりでいいなら以下のようにすればよくないですか?

 .Cells(i, "C").Value = "完了"
      ↓
 .Cells(i, "C").Value = "完了"
 Exit For

■3
細かい話ですが、以下でもよいかとおもいます。(「wbList」の出番がそこしかないので)

 Set wbList = Workbooks.Open(Path01)
 Set wsList = wbList.Worksheets("※編集禁止※ALL(数式あり)")
   〜
 wbList.Close SaveChanges:=False

 Set wsList = Workbooks.Open(Path01).Worksheets("※編集禁止※ALL(数式あり)")
   〜
 wbList.Parent.Close SaveChanges:=False

■4
好みの問題でしょうが↓だとブックを指定しなかった場合コケますよね。
なのでブックを指定しなかったら処理を中止するようにされたらどうでしょうか?

 Path01 = Application.GetOpenFilename
 Set wbList = Workbooks.Open(Path01)

 Path02 = Application.GetOpenFilename
 Set wbDel = Workbooks.Open(Path02)

■5
代理店マスタを元に、配信用シートを特定
ループ処理で見ていくのも間違いではないですが↓のような方法もあります。

        Set wsdel = Nothing  'ここで初期化
        On Error Resume Next
        Set wsdel = wbDel.Worksheets(TargetName) 'セットに失敗すると「Nothing」のままになる
        On Error GoTo 0

        If wsdel Is Nothing Then
            MsgBox TargetName & "シートがないっす"
        End If

■6
以下は、何を期待している処理なのでしょうか?(なにも取得してないのだから、初期値の""がイミディエイトに出力されるだけですよね)

 C As String
 Debug.Print C

(もこな2) 2023/01/27(金) 14:37:18


おはようございます。
先お二方のアドバイス後、下記のようにコードを改変して解決しましたので、お礼と本件クローズの旨を投稿したのですが、反映されておりませんでした。
すみませんでした。
みなさまのアドバイスを元に勉強させていただきます。
ありがとうございました。

>もこな2さん
はい、何も出力されませんでした。デバックの仕方が正しく理解できていないので、もう一度勉強いたします。

Sub organizingData()

Dim wbList As Workbook, wbDel As Workbook, wbThis As Workbook
Dim ws As Worksheet, wsList As Worksheet, wsDel As Worksheet
Dim Path01 As String, Path02 As String, targetName As String
Dim LastRow As Long, i As Long

Set wbThis = ThisWorkbook

'Ph.G対象者リストを開く
Set wbList = Workbooks.Open(wbThis.Worksheets("VBA始動").Cells(5, "D").Value)
Set wsList = wbList.Worksheets("※編集禁止※ALL(数式あり)")

'代理店配信シートを開く
Set wbDel = Workbooks.Open(wbThis.Worksheets("VBA始動").Cells(7, "D").Value)

'代理店マスタを元に、配信用シートを特定し、Ph.G対象者リストからコピー&ペースト
Set ws = wbThis.Worksheets("代理店マスタ")
LastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

Application.ScreenUpdating = False

'マスタシートのB列を2行目からループ処理
With ws

    .Range(.Range("H2"), .Cells(Rows.Count, "H").End(xlUp)).ClearContents
End With
For i = 2 To LastRow
    '対象者をマスターシートから変数に入れる
    targetName = ws.Cells(i, "B").Value
    'wsDELに対象者のシートがあるかチェックし、シートがあれば処理を続ける
    'wbDel.Activate
    If Evaluate("ISREF(" & targetName & "!A1)") = True Then
        Set wsDel = wbDel.Worksheets(targetName)
        wsDel.Range("A4:E" & wsDel.Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
        'フィルター結果のコピー
        With wsList
            With .Range("A1")
                .AutoFilter 2, "〇"
                .AutoFilter 30, targetName
            End With
            .Range("J5:N" & .Cells(Rows.Count, "N").End(xlUp).Row).Copy
        End With
        'wsDelに結果を書き込み
        wsDel.Range("A4").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        'マスターに結果を入力
        ws.Cells(i, "H").Value = "完了"
    Else
        ws.Cells(i, "H").Value = "未完了"
    End If
Next i

Application.ScreenUpdating = True
'ブックを閉じる
Application.DisplayAlerts = False
wbList.Close SaveChanges:=False
Application.DisplayAlerts = True

End Sub
(トリちゃん) 2023/02/02(木) 08:49:40


ざっと眺めた程度なので、読み間違っているかもしれませんが整理するとこんな感じですよね
    Sub 整理()
        Dim wbDel As Workbook
        Dim 対象者リストSH As Worksheet, 代理店配信SH As Worksheet, 代理店マスタSH As Worksheet
        Dim i As Long

        With ThisWorkbook.Worksheets("VBA始動")
            Set 対象者リストSH = Workbooks.Open(.Range("D5").Value).Worksheets("※編集禁止※ALL(数式あり)")
            Set wbDel = Workbooks.Open(.Range("D7").Value)
        End With

        With ThisWorkbook.Worksheets("代理店マスタ")
            .Range("H2", .Cells(.Rows.Count, "H").End(xlUp)).ClearContents

            For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
                On Error Resume Next
                Set 代理店配信SH = Nothing
                Set 代理店配信SH = wbDel.Worksheets(Cells(i, "B").Value)
                On Error GoTo 0

                If 代理店配信SH Is Nothing Then
                    .Cells(i, "H").Value = "未完了"
                Else
                    対象者リストSH.AutoFilterMode = False 'オートフィルタを一旦解除
                    対象者リストSH.Range("A1").AutoFilter 2, "〇"
                    対象者リストSH.Range("A1").AutoFilter 30, .Cells(i, "B").Value
                    対象者リストSH.Range("J5", 対象者リストSH.Cells(対象者リストSH.Rows.Count, "N").End(xlUp)).Copy

                    代理店配信SH.Range("A4").PasteSpecial xlPasteValues

                    .Cells(i, "H").Value = "完了"
                End If
            Next i
        End With

        Application.DisplayAlerts = False
        対象者リストSH.Parent.Close SaveChanges:=False
        Application.DisplayAlerts = True
    End Sub

余計なお世話かもしれませんが、せっかく更新した↓も保存するようにされたらどうでしょうか?

 Workbooks.Open(ThisWorkbook.Worksheets("VBA始動").Range("D7").Value)

(もこな2) 2023/02/02(木) 16:07:27


 すんませんね、整頓されてなくて。
(稲葉) 2023/02/02(木) 16:12:30

>すんませんね、整頓されてなくて。

>>整理するとこんな感じですよね
↑は「(トリちゃん) 2023/02/02(木) 08:49:40」に提示されたものを見ての話なので、稲葉さんのコードに対してではないです。

 ちなみに、トピ主不採用orレスなしでしたが、コードを拝見して流れが大体わかったので
 私の好みで「■1」「■3」「■5」のエッセンスを組み込んでみました。

(もこな2) 2023/02/02(木) 20:38:57


もこな2さん
こんな書き方もあるんですね。
勉強になります。
ありがとうございました。
(トリちゃん) 2023/02/03(金) 01:56:11

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.