別のExcelから削除する値を取得して、一定間隔を削除したい

投稿者 : マロン     投稿日時 : 2024/11/26(Tue) 18:09:21     OS : 未指定     EXCEL : 未指定

---

Excelのマクロ初心者で困っております。
どなたか、知恵を拝借して頂ければ、幸いです……

☆やりたい事
Excel①に削除したい項目があり、その削除したい値を取得して、Excel②からその項目を削除したい。
ただし、削除するのは次の項目列まで

☆例
Excel①のD列に削除したい項目があります。
（りんご、ばなな、ぶどう、みかん……等）

Excel②のB列に項目が並んでいます。
ただし、B1、B2、B3と連続して並んでいる訳ではなく、
B5にりんご、B10にみかん、B20にぶどう、という配列で、B5～B9は空白の状態です。

Excel①のD列にりんごがあった場合、Excel②のB5～B9を削除したいのです。


☆作成マクロ
以下のようにマクロを作成しましたが、うまく動かず……。


'ThisWorkbookのSheet1をws1という変数に代入
Dim ws1 As Worksheet
Set ws1 = Workbooks("Excel①.xlsm").Worksheets("Sheet1")


'別ブックのSheet1をws2という変数に代入
Dim ws2 As Worksheet
Set ws2 = Workbooks("Excel②.xlsx").Worksheets("Sheet1")

'ws1のK2から最終行までをループ
Dim y As Long
For y = 2 To ws1.Cells(ws1.Rows.Count, "D").End(xlUp).Row

'ws1のK列の値をfruitという変数に代入
Dim fruit As String
fruit = ws1.Cells(y, "D").Value

'ws2のD2から最終行までをループ
Dim j As Long
For j = 2 To lstRow
'ws2のN列の値をproductという変数に代入
Dim product As String
product = ws2.Cells(j, "B").Value

'productがfruitを含むかどうか判定
If InStr(product, fruit) > 0 Then


For k = lstRow To 2 Step -1

'果物削除
If Cells(i, 2) Like "*" & fruit & "*" Then
Rows(i).Delete
End If

Next k

End If
Next j
Next y

End If


申し訳ございませんが、どなたか助けて頂けると大変たすかります。
よろしくお願いいたします。

投稿者 : てらてら     投稿日時 : 2024/11/26(Tue) 20:38:50

---

こんにちは。

最後の行に、検索文字があるとそれ以降の空白列を削除し続けるので無限ループになります。
なので、最後の行に検索文字があった時は、その行だけ削除する事にします。

Sub macro()
    'ThisWorkbookのSheet1をws1という変数に代入
    Dim ws1 As Worksheet
    Set ws1 = Workbooks("Excel①.xlsm").Worksheets("Sheet1")
    
    '別ブックのSheet1をws2という変数に代入
    Dim ws2 As Worksheet
    Set ws2 = Workbooks("Excel②.xlsx").Worksheets("Sheet1")
    
    'ws1のK2から最終行までをループ　<---???
    Dim y As Long
    For y = 2 To ws1.Cells(Rows.Count, "D").End(xlUp).Row
    
        Dim fruit As String
        fruit = ws1.Cells(y, "D").Value
        
        Dim j As Long, i As Long
        Dim lstRow As Long
        Dim product As String
        
        lstRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row
        
        For j = lstRow To 2 Step -1
            product = ws2.Cells(j, "B").Value
            
            If InStr(product, fruit) > 0 Then
                ws2.Rows(j).Delete
                i = j
                
                If i = lstRow Then Exit For

                Do While ws2.Cells(i, "B") = ""
                    ws2.Rows(i).Delete
                Loop
            End If
         
        Next j
    Next y

End Sub

投稿者 : マロン     投稿日時 : 2024/11/27(Wed) 17:44:09

---

ありがとうございます！

おかげで何とか動きました。助かりました。

投稿者 : マロン     投稿日時 : 2024/11/27(Wed) 17:59:34

---

申し訳ございません。

該当箇所を「削除」したかったのですが、急遽「非表示」に変更になってしまいました。
自分なりに、.EntireRow.Hidden = True　と入力してみたのですが、
一カ所しか非表示になりませんでした。

再三で申し訳ございませんが、再度お力を貸して頂けないでしょうか。



If InStr(product, tekiyou) > 0 Then
ws2.Rows(j).EntireRow.Hidden = True
l = j

If l = lstRow Then Exit For

Do While ws2.Cells(l, "B") = ""
ws2.Rows(l).EntireRow.Hidden = True
Loop
End If

投稿者 : てらてら     投稿日時 : 2024/11/27(Wed) 20:03:50

---

削除と非表示のExcelの挙動を考えれば、コードを書き直さなければならないとわかるはずです。

Sub macro()
    'ThisWorkbookのSheet1をws1という変数に代入
    Dim ws1 As Worksheet
    Set ws1 = Workbooks("Excel①.xlsm").Worksheets("Sheet1")
    '別ブックのSheet1をws2という変数に代入
    Dim ws2 As Worksheet
    Set ws2 = Workbooks("Excel②.xlsx").Worksheets("Sheet1")
    
    
    'ws1のK2から最終行までをループ　<---???
    Dim y As Long
    For y = 2 To ws1.Cells(Rows.Count, "D").End(xlUp).Row
    
        Dim fruit As String
        fruit = ws1.Cells(y, "D").Value
        
        Dim j As Long, i As Long
        Dim lstRow As Long
        Dim product As String
        
        lstRow = ws2.Cells(Rows.Count, "B").End(xlUp).Row
        
        For j = lstRow To 2 Step -1
            product = ws2.Cells(j, "B").Value
            
            If InStr(product, fruit) > 0 Then
                ws2.Rows(j).EntireRow.Hidden = True
                i = j + 1
                If i > lstRow Then Exit For

                Do While ws2.Cells(i, "B") = ""
                    ws2.Rows(i).EntireRow.Hidden = True
                    If i > lstRow Then Exit Do
                    i = i + 1
                Loop
            End If
         
        Next j
    Next y

End Sub

投稿者 : マロン     投稿日時 : 2024/11/28(Thu) 11:43:22

---

どうもありがとうございました。

とても勉強になりました。