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

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

1 个答案: