Sub 判別して記入()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim keyRange As Range
Dim cell As Range
Dim keyArray() As Variant
Dim keyIndex As Long
Dim labels() As String
Dim labelIndex As Long
Dim label As String
' シート1とシート2を設定
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
' シート1の最終行を取得
lastRow1 = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
' シート2のキーの範囲を配列に読み込む
lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
keyArray = ws2.Range("A1:A" & lastRow2).Value
' シート1の各セルについて処理
For Each cell In ws1.Range("C1:C" & lastRow1)
If cell.Value <> "" Then
' カンマで区切られたラベルを配列に格納
labels = Split(cell.Value, ",")
' ラベルの配列に対して処理
For labelIndex = LBound(labels) To UBound(labels)
label = Trim(labels(labelIndex)) ' ラベルの前後の空白を削除
If label <> "" Then ' 空のラベルは無視
' キーのチェック
For keyIndex = LBound(keyArray, 1) To UBound(keyArray, 1)
If InStr(1, label, keyArray(keyIndex, 1)) > 0 Then
label = "keyword1"
Exit For
End If
Next keyIndex
' 最初の文字が3、4、または5の場合
If Left(label, 1) Like "[3456]" Then
label = "判別11"
''' ' セルの背景色を黄色に設定
''' cell.Interior.Color = RGB(255, 255, 0) ' 黄色
Else
' 最初の文字がアルファベットの場合
If Asc(UCase(Left(label, 1))) >= 65 And Asc(UCase(Left(label, 1))) <= 90 Then
label = "判別12"
Else
' 1234と5678の場合
Select Case label
Case "1234"
label = "判別13"
Case "5678"
label = "判別14"
Case "1111"
label = "判別15"
Case "2222"
label = "判別61"
Case Else
End Select
End If
End If
' 最初のラベルが空でない場合
If label <> "" Then
' 既存のD列の値にラベルを追加
If ws1.Cells(cell.Row, "D").Value <> "" Then
ws1.Cells(cell.Row, "D").Value = ws1.Cells(cell.Row, "D").Value & "," & label
Else
ws1.Cells(cell.Row, "D").Value = label
End If
End If
End If
Next labelIndex
End If
Next cell
End Sub
