Раздел комментариев столбца к категориальным данным как отдельным рабочим листам

Question

Я пытаюсь написать код, который использует таблицу конкретных ключевых слов для сопоставления данных для нескольких строк в одном столбце на рабочем листе и классификации этих совпадений как отдельных рабочих листов со всеми другими связанными данными в той же рабочей книге.

Я пытался исследовать код разделения и код разбора

Sub SplitData()
    Const lngNameCol = 2 ' Blue Sheet Issue
    Const lngFirstRow = 2 ' data start in row 2
    Dim wshSource As Worksheet
    Dim wshTarget As Worksheet
    Dim lngRow As Long
    Dim lngLastRow As Long
    Dim lngTargetRow As Long
    Application.ScreenUpdating = False
    Set wshSource = ActiveSheet
    lngLastRow = wshSource.Cells(wshSource.Rows.Count, lngNameCol).End(xlUp).Row
    For lngRow = lngFirstRow To lngLastRow
        If wshSource.Cells(lngRow, lngNameCol).Value <> wshSource.Cells(lngRow - 1, lngNameCol).Value Then
            Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshTarget.Name = wshSource.Cells(lngRow, lngNameCol).Value
            wshSource.Rows(lngFirstRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
            lngTargetRow = 2
        End If
        wshSource.Rows(lngRow).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
        lngTargetRow = lngTargetRow + 1
    Next lngRow
    Application.ScreenUpdating = True
End Sub

Это только уходит от столбца. Необходимо сопоставить его с конкретными ключевыми словами. Попытка преобразовать столбец данных раздела комментариев (коды, сокращения, слова) в несколько листов.

Answer 1

Это довольно просто, но даст вам отправную точку:

Sub SplitMeUp()

    Dim regEx As Object, rngWords As Range, rngComments As Range
    Dim w As Range, c As Range, sht As Worksheet, wb As Workbook

    'https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/scripting-articles/ms974570(v=msdn.10)
    Set regEx = CreateObject("vbscript.regexp")
    regEx.Global = True
    regEx.IgnoreCase = True

    'example ranges
    Set wb = ThisWorkbook
    Set rngWords = wb.Sheets("legend").Range("A1:A3")
    Set rngComments = wb.Sheets("Sheet1").Range("H2:H100")

    'loop over the list of words
    For Each w In rngWords
        Set sht = Nothing
        regEx.Pattern = "\b" & w.Value & "s?\b" 'word plus optional "s"
        'loop over the comments
        For Each c In rngComments.Cells
            If regEx.test(c.Value) Then
                'found a match
                If sht Is Nothing Then
                    'make sure there's a sheet to copy to
                    On Error Resume Next
                    Set sht = wb.Worksheets(w.Value)
                    On Error GoTo 0
                    If sht Is Nothing Then
                        'no sheet already, so create one
                        Set sht = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
                        sht.Name = w.Value
                    End If
                End If

                'copy the row over
                c.EntireRow.Cells(1).Resize(1, 10).Copy _
                    sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1, 0)

            End If
        Next c
    Next w

End Sub