列注释部分，将数据分类为单独的工作表

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://learn.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