Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Excel 2019)
特定の抽出について
投稿日時: 22/06/04 18:38:20
投稿者: nexfinity0215

お世話になります。Like演算子について質問です。
下記のコードで、"抽出ワード"シートを活用し、別シートへ「末尾の文字を含む」抽出はできたのですが、含まない抽出をしたいのですが、 If .Cells(r1, 4).Value Like "*" & tbl(i, 1) ThenをIfNot( .Cells(r1, 4).Value Like "*" & tbl(i, 1) )Thenにしてもうまくいきません…Elseをつかってシート足すにもうまく機能してくれないので、アドバイスを頂けたら、幸いです。
 
したい事:
抽出元は、5行目からデータがあります。
抽出場所は、D列の数値と英字があり、抽出ワードは、英字と数字となります。(A列に記載)
抽出場所は、抽出先は5行目以降に抽出したいです。
 
 
Sub test()
 Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
 Dim tbl As Variant
 Dim i As Long
 Dim r1 As Long, r3 As Long
 Dim ctbl As Variant
 Dim j As Integer
 ctbl = Array(3, 4, 7, 8, 14)
 
Application.ScreenUpdating = False
 
 r3 = 4
 Set ws1 = Worksheets("抽出元")
 Set ws2 = Worksheets("抽出先")
 Set ws3 = Worksheets("抽出ワード")
 
With ws2
 If .Cells(5, 1).Value <> "" Then
  .Range("A5:E" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
 End If
End With
 
With ws3
 tbl = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
 
With ws1
 For r1 = 5 To .Cells(Rows.Count, 5).End(xlUp).Row
  For i = 1 To UBound(tbl)
   If .Cells(r1, 4).Value Like "*" & tbl(i, 1) Then
    r3 = r3 + 1
     For j = 0 To 4
      ws2.Cells(r3, j + 1).Value = .Cells(r1, ctbl(j)).Value
     Next j
   End If
  Next i
 Next r1
End With
 
Application.ScreenUpdating = True
End Sub

回答
投稿日時: 22/06/04 18:59:20
投稿者: simple

末尾に含まないなら今の方式でよいでしょう。
位置を問わずなら、
"*" & tbl(i, 1) & "*"
と比較します。

投稿日時: 22/06/04 19:20:04
投稿者: nexfinity0215

Simpleさんご返信ありがとうございます。
抽出ワードが含まないのを抽出先に出したいのですが、いまのコードですと、末尾に抽出ワードがあるのが、抽出先に抽出されてしまいます…

回答
投稿日時: 22/06/04 19:35:57
投稿者: simple

通じなかったようです。もう一度。
 
末尾に含まないなら、今のトライ式

If Not( .Cells(r1, 4).Value Like "*" & tbl(i, 1) )Then
でよいでしょう。
 
位置を問わず含まないなら、
If Not( .Cells(r1, 4).Value Like "*" & tbl(i, 1) & "*"  )Then
でよいでしょう。
 
# カッコは不要ですが、分かりやすさ優先しています。

投稿日時: 22/06/04 20:26:16
投稿者: nexfinity0215

それでやると、同じ値がなん個も表示されるのですが、どこかコードが悪さをしてるのでしょうか…?

回答
投稿日時: 22/06/04 21:15:52
投稿者: simple

焦点となっているポイントしか見ておりません。
 
仕様をもう一度明確に書いてもらえますか?

引用:
したい事:
抽出元は、5行目からデータがあります。
抽出場所は、D列の数値と英字があり、抽出ワードは、英字と数字となります。(A列に記載)
抽出場所は、抽出先は5行目以降に抽出したいです。
これだけでは、あなたの意図が伝わりません。
>同じ値がなん個も表示される
と言われても、書かれていないことは人には伝わりません。

投稿日時: 22/06/05 07:22:34
投稿者: nexfinity0215

If Not( .Cells(r1, 4).Value Like "*" & tbl(i, 1) )Thenで、下記のコードで実行すると、
Sub test()
 Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
 Dim tbl As Variant
 Dim i As Long
 Dim r1 As Long, r3 As Long
 Dim ctbl As Variant
 Dim j As Integer
 ctbl = Array(3, 4, 7, 8, 14)
  
Application.ScreenUpdating = False
  
 r3 = 4
 Set ws1 = Worksheets("抽出元")
 Set ws2 = Worksheets("抽出先")
 Set ws3 = Worksheets("抽出ワード")
  
With ws2
 If .Cells(5, 1).Value <> "" Then
  .Range("A5:E" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
 End If
End With
  
With ws3
 tbl = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
  
With ws1
 For r1 = 5 To .Cells(Rows.Count, 5).End(xlUp).Row
  For i = 1 To UBound(tbl)
   If Not( .Cells(r1, 4).Value Like "*" & tbl(i, 1) )Then
    r3 = r3 + 1
     For j = 0 To 4
      ws2.Cells(r3, j + 1).Value = .Cells(r1, ctbl(j)).Value
     Next j
   End If
  Next i
 Next r1
End With
  
Application.ScreenUpdating = True
End Sub
 
抽出元データの5行目以降のデータが、1つの値が28個ずつコピーして、抽出され、抽出先に表示されます。
また、抽出ワードを含むまないものだけを抽出したいのですが、上記のコードですと、抽出ワード関係なく、28個ずつ増えて、抽出先に抽出されます。
 
 
例:
抽出元 D5の値が、1234567890とすると
抽出先 B5からB31まで123467890が繰り返し抽出されてます。
 
やりたいことは、抽出ワードに1,2,AからZの数英字をA列に格納してあります(28個)、抽出元D列の末尾に1,2,AからZの数英字を含まないものを抽出したいです。
 
抽出元 D5の値が、1234567890とすると
抽出先 B5に123467890抽出し、
抽出元 D6の値が、1234567890Aとすると、抽出はしないという風にしたいのですが、、、、
 
多分、28個コピーされているので、抽出ワードをループして数ぶん抽出しているように思えるのですが…

回答
投稿日時: 22/06/05 07:22:36
投稿者: simple

あれ、直ぐに返事があるかと思っていましたが。
 
否定をANDでつないでもいいですし、以下のような書き方もできるでしょう。

Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim tbl     As Variant
    Dim i       As Long
    Dim r1      As Long
    Dim r3      As Long
    Dim ctbl    As Variant
    Dim j       As Integer
    Dim matchflag As Boolean

    Application.ScreenUpdating = False

    Set ws1 = Worksheets("抽出元")
    Set ws2 = Worksheets("抽出先")
    Set ws3 = Worksheets("抽出ワード")

    '書き込み先のクリアー
    With ws2
        If .Cells(5, 1).Value <> "" Then
            .Range("A5:E" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
        End If
    End With

    '文字列テーブル
    tbl = ws3.Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)

    '抽出
    ctbl = Array(3, 4, 7, 8, 14)
    r3 = 4
    With ws1
        For r1 = 5 To .Cells(Rows.Count, 5).End(xlUp).Row
            matchflag = False
            For i = 1 To UBound(tbl)
                If .Cells(r1, 4).Value Like "*" & tbl(i, 1) Then
                    matchflag = True
                    Exit For
                End If
            Next i
            If matchflag = False Then
                r3 = r3 + 1
                For j = 0 To 4
                    ws2.Cells(r3, j + 1).Value = .Cells(r1, ctbl(j)).Value
                Next j
            End If
        Next r1
    End With
    Application.ScreenUpdating = True
End Sub

投稿日時: 22/06/05 08:22:16
投稿者: nexfinity0215

昨日は野暮用がありご返信が遅れて申し訳ありません…
Simpleさんのコードでできました!とても参考になりました!
いつもありがとうございます!また色々とわからない事がありましたら、質問することもありますが、何卒よろしくお願いいたします。