アンケート調査ラベリング（個人用）

Sub ProcessExcelSheet()
Dim wb As Workbook
Dim newWb As Workbook
Dim ws As Worksheet
Dim filePath As String
Dim fileName As String
Dim newFileName As String

' 元のブックのパスと名前を取得
filePath = ThisWorkbook.Path
fileName = ThisWorkbook.Name
newFileName = filePath & "\" & Replace(fileName, ".xlsm", "") & "_done.xlsx"

' 元のブックをコピーして新しいブックを保存
ThisWorkbook.SaveCopyAs newFileName
Set newWb = Workbooks.Open(newFileName)
Set ws = newWb.Sheets(1)

' E列をキーにして昇順に並べ替え
With ws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=ws.Range("E2:E" & ws.Cells(ws.Rows.Count, "E").End(xlUp).Row), Order:=xlAscending
    .SetRange ws.Range("A1:E" & ws.Cells(ws.Rows.Count, "E").End(xlUp).Row)
    .Header = xlYes
    .Apply
End With

' 2行目から抽出処理を開始
Dim i As Long
For i = 2 To ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    If ws.Cells(i, 5).Value = "" Then Exit For
    ' ↓6列目にラベルを吐き出す。変えたければws.Cells(i,n（任意の列）)に
    ws.Cells(i, 6).Value = extraction(ws.Cells(i, 5).Value, Worksheets("rule").Range("A1:AV39"))
Next i

' 処理完了後の通知
MsgBox "処理が完了しました。ファイルは " & newFileName & " に保存されました。"

End Sub

Function extraction(S1 As String, R1 As Range) As String
Dim i As Integer, j As Integer
Dim V1 As Variant
V1 = R1.Value
For i = LBound(V1, 1) To UBound(V1, 1)
For j = LBound(V1, 2) + 1 To UBound(V1, 2)
If V1(i, j) <> "" And InStr(1, S1, V1(i, j), vbTextCompare) > 0 Then
extraction = V1(i, 1)
Exit Function
End If
Next j
Next i
End Function

これをこのままコピペする