☰

セル範囲からカンマ区切りの複数の値を抽出する

tag-icon • tag-icon microsoft-excel microsoft-excel-2010
セル範囲からカンマ区切りの複数の値を抽出する

各セルに一意の値を持つデータ行で値セット (3 または 4 の値セット) を検索し、値の一部またはすべてが一致する場合は、必要に応じてカンマ区切りで対象の単一セルに抽出しようとしています。これを実現するための支援があればありがたいです。ありがとうございます。ここが難しいところですが、検索する値は単一セルにカンマ区切りで存在します。

ここに画像の説明を入力してください

答え1

私は自分の質問に答えましたが、以下のコードはそれぞれの開発者によって提案されたものです。いずれかのコードを使用する場合は、シート内のデータの位置に応じてコードを配置する必要がある場合があります。

1) この解決策は、MrExcel の Rick Rothstein 氏によって提案されています。

Sub GetValues()

 Dim R As Long, C As Long, V As Variant, Txt As String
  For C = 11 To Cells(1, Columns.Count).End(xlToLeft).Column
    For R = 3 To Cells(Rows.Count, "A").End(xlUp).Row
      Txt = ""
      For Each V In Split(Cells(1, C).Value, ",")
        If Not Intersect(Rows(R), Columns("A:I")).Find(V, , , xlWhole, , , False, `enter code here`False) Is Nothing Then Txt = Txt & "," & V
      Next
      Cells(R, C).Value = Mid(Txt, 2)
    Next
  Next
End Sub

2) ここに別の代替コードがあります (Terry X に感謝します):

Sub Test()

startCol = 11

EndCol = 13

'EndCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column

StartRow = 5

EndRow = 7

'EndRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

Dim arr As Variant

Dim dataRng As Range

For i = StartRow To EndRow

     Set dataRng = Range(Cells(i, 1), Cells(i, 8))

     dataRng.Select

     For j = startCol To EndCol

     valueToLookUP = Cells(1, j).Value

     arr = Split(valueToLookUP, ",")

     resultStr = ""

     For k = LBound(arr) To UBound(arr)

     On Error Resume Next

     idx = WorksheetFunction.Match(arr(k), dataRng, 0)

     If idx > 0 Then

     resultStr = resultStr + "," + arr(k)

     End If

     idx = 0

     Next k

     If Len(resultStr) > 0 Then resultStr = Mid(resultStr, 2)

     Cells(i, j).Value = resultStr

     Next j

Next i

End Sub

3) ボタンを使った別のアプローチ (Ashidacchi さんに感謝):

ここに画像の説明を入力してください

Option Explicit

Private kw1, kw2, kw3, kw4 As String
Private match1, match2, match3, match4 As String
Private strTarget As String

' ---[Smart Search]
Private Sub btn_SmartSearch_Click()
    Dim firstRow As Integer: firstRow = 5
    Dim lastRow As Integer: lastRow = Range("A99999").End(xlUp).Row
    ' ---
    Dim myRow As Integer
    For myRow = firstRow To lastRow
        Call prc_Clear_Match_KW             ' -- clear match1~match4, kw1~kw4
        Call prc_Create_TargetString(myRow) ' -- create strTarget
        ' ---
        If (strTarget <> "") And (Range("K1").Value <> "") Then
            Dim commaCnt As Integer ' -- the number of comma(s) in cell [K1]
            Dim kwCnt As Integer    ' -- the number of keyword(s) in cell [K1]
            ' ---
            commaCnt = Len(Range("K1")) - Len(Replace(Range("K1"), ",", ""))
            kwCnt = commaCnt + 1
            Call prc_Set_Keyword(kwCnt)
            'MsgBox "kwCnt=" & kwCnt
            ' --- kw ‚ª‘¶Ý‚·‚ê‚Î match ‚É kw ‚ðƒZƒbƒg
            If (InStr(strTarget, kw1) > 0) Then
                match1 = kw1
            End If
            If (InStr(strTarget, kw2) > 0) Then
                match2 = kw2
            End If
            If (InStr(strTarget, kw3) > 0) Then
                match3 = kw3
            End If
            If (InStr(strTarget, kw4) > 0) Then
                match4 = kw4
            End If
            ' --- set matching result to column [K]
            Call prc_Set_Result(myRow)
        End If
    Next
    ' ---
    MsgBox "[Smart Search] completed !!)"
End Sub
' -- create strTarget: concatenate cells 1 - 8
Private Sub prc_Create_TargetString(ByVal myRow As Integer)
    strTarget _
        = Cells(myRow, 1).Value & Cells(myRow, 2).Value _
        & Cells(myRow, 3).Value & Cells(myRow, 4).Value _
        & Cells(myRow, 5).Value & Cells(myRow, 6).Value _
        & Cells(myRow, 7).Value & Cells(myRow, 8).Value
        '' --- for debugging
        ' MsgBox "strTarget=" & strTarget
End Sub
' ---
Private Sub prc_Set_Keyword(ByVal kwCnt As Integer)
    Select Case kwCnt
        Case Is = 1     ' -- one Keyword
            kw1 = Mid(Range("K1").Value, 1, 1)
        Case Is = 2     ' -- two Keywords
            kw1 = Mid(Range("K1").Value, 1, 1)
            kw2 = Mid(Range("K1").Value, 3, 1)
        Case Is = 3     ' -- three Keywords
            kw1 = Mid(Range("K1").Value, 1, 1)
            kw2 = Mid(Range("K1").Value, 3, 1)
            kw3 = Mid(Range("K1").Value, 5, 1)
        Case Is = 4     ' -- four Keywords
            kw1 = Mid(Range("K1").Value, 1, 1)
            kw2 = Mid(Range("K1").Value, 3, 1)
            kw3 = Mid(Range("K1").Value, 5, 1)
            kw4 = Mid(Range("K1").Value, 7, 1)
    End Select
    '' --- for debugging
'    MsgBox "kw1=" & kw1 & Chr(13) & _
'           "kw2=" & kw2 & Chr(13) & _
'           "kw3=" & kw3 & Chr(13) & _
'           "kw4=" & kw4
End Sub
' ---
Private Sub prc_Clear_Match_KW()
    match1 = ""
    match2 = ""
    match3 = ""
    match4 = ""
    ' --
    kw1 = ""
    kw2 = ""
    kw3 = ""
    kw4 = ""
End Sub
' ---
Private Sub prc_Set_Result(ByVal myRow As Integer)
    Dim strResult As String: strResult = ""
    If (match1 <> "") Then
        strResult = match1
    End If
    If (match2 <> "") Then
        strResult = strResult & "," & match2


End If
    If (match3 = "") Then
        strResult = strResult & "," & match3
    End If
    If (match4 = "") Then
        strResult = strResult & "," & match3
    End If
    ' ---
    Do Until Left(strResult, 1) <> ","
        strResult = Mid(strResult, 2, Len(strResult) - 1)
    Loop
    Do Until Right(strResult, 1) <> ","
        strResult = Mid(strResult, 1, Len(strResult) - 1)
    Loop
    ' ---
    Cells(myRow, 11).Value = strResult
End Sub
' ---[Clear Result]
Private Sub btn_ClearResult_Click()
    Range("K5:T50").Value = ""
End Sub

関連情報