Question

我发现以下代码适用于查找某个标题并复制其下方的行。

Private Sub Search_n_CopyV2()
    Dim ws As Worksheet
    Dim rngCopy As Range, aCell As Range, bcell As Range
    Dim strSearch As String

    strSearch = "Box E"

    Set ws = Worksheets("Original")

    With ws
        Set aCell = .Columns(3).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bcell = aCell

            If rngCopy Is Nothing Then
                Set rngCopy = .Rows(aCell.Row + 1)
            Else
                Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1)))
            End If

            Do
                Set aCell = .Columns(3).FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bcell.Address Then Exit Do

                    If rngCopy Is Nothing Then
                        Set rngCopy = .Rows(aCell.Row + 1)
                    Else
                        Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1)))
                    End If
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox SearchString & " not Found"
        End If

        If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Rows(1)
    End With
End Sub

我希望改变这一点，以便我可以抵消复制某些细胞。

原始数据格式：

预期结果：

我不确定编辑当前代码以实现这些结果的最佳方法是什么。

Answer 1

这是一些新代码可以满足您的需求。你得到了投票，因为实际上你要求其他人为你编写代码。 StackOverflow更多的是让程序员在遇到技术问题时解开。

Option Explicit

Sub SetupData()
    '* Run Once to set up test data as given in the question's screenshots
    Dim ws As Excel.Worksheet
    Set ws = Sheet1

    ws.Range("A1:C2").Value2 = Application.Evaluate("{""Box A"",""Box C"",""Box E"";""Value 1"",""Value 2"",""Value 3""}")
    ws.Range("A3:C4").Value2 = Application.Evaluate("{""Box B"",""Box D"",""Box F"";""Value 4"",""Value 5"",""Value 6""}")

    ws.Range("A7:C8").Value2 = Application.Evaluate("{""Box A"",""Box C"",""Box E"";""Value 7"",""Value 8"",""Value 9""}")
    ws.Range("A9:C10").Value2 = Application.Evaluate("{""Box B"",""Box D"",""Box F"";""Value 10"",""Value 11"",""Value 12""}")

    ws.Range("A13:C14").Value2 = Application.Evaluate("{""Box A"",""Box C"",""Box E"";""Value 13"",""Value 14"",""Value 15""}")
    ws.Range("A15:C16").Value2 = Application.Evaluate("{""Box B"",""Box D"",""Box F"";""Value 16"",""Value 17"",""Value 18""}")


End Sub

Sub TestCollateData()
    '* Run this
    Dim dic As Object  'Scripting.Dictionary
    Set dic = CollateData(Sheet1)

    WriteData dic
End Sub

Sub WriteData(ByVal dic As Object)  'ByVal dic As Scripting.Dictionary
    '* This writes the results to the sheet, it adds a new sheet every time
    Dim wsWrite As Excel.Worksheet
    Set wsWrite = ThisWorkbook.Worksheets.Add
    wsWrite.Name = "Results"

    Dim vBoxLoop As Variant, lColLoop As Long
    lColLoop = 0
    For Each vBoxLoop In dic.Keys
        lColLoop = lColLoop + 1
        wsWrite.Cells(1, lColLoop) = vBoxLoop

        Dim vValues As Variant
        vValues = dic.Item(vBoxLoop)

        Dim lCount As Long
        lCount = UBound(vValues) - LBound(vValues) + 1

        Dim rngValues As Excel.Range
        Set rngValues = wsWrite.Cells(2, lColLoop).Resize(lCount)

        rngValues.Value2 = Application.Transpose(vValues)

    Next

End Sub

Function CollateData(ByVal ws As Excel.Worksheet) As Object 'Scripting.Dictionary
    '* This collates the data initially into a nested dictionary
    '* and then into a single 'flattened' dictionary
    Dim dicCollated As Object 'Scripting.Dictionary
    Set dicCollated = VBA.CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary

    Dim rngUsedLoop As Excel.Range
    For Each rngUsedLoop In ws.UsedRange
        Dim vLoop As Variant
        vLoop = rngUsedLoop.Value2

        If Not IsEmpty(vLoop) Then
            If StrComp(Left$(vLoop, 4), "Box ", vbTextCompare) = 0 Then
                Dim sBox As String
                sBox = Trim(vLoop)

                Dim dicBox As Object 'Scripting.Dictionary
                If Not dicCollated.Exists(sBox) Then
                    Set dicBox = VBA.CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
                    dicCollated.Add sBox, dicBox
                Else
                    Set dicBox = dicCollated.Item(sBox)
                End If

                Dim vUnderTheBox As Variant
                vUnderTheBox = rngUsedLoop.offset(1, 0).Value2

                If Not dicBox.Exists(vUnderTheBox) Then
                    dicBox.Add vUnderTheBox, 0
                End If

            End If
        End If
    Next

    Dim dicFlattened As Object 'Scripting.Dictionary
    Set dicFlattened = VBA.CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary

    Dim vBoxLoop As Variant
    For Each vBoxLoop In dicCollated.Keys


        Set dicBox = dicCollated.Item(vBoxLoop)

        Dim vBoxKeys As Variant
        vBoxKeys = dicBox.Keys

        dicFlattened.Add vBoxLoop, vBoxKeys

    Next vBoxLoop

    Set CollateData = dicFlattened
End Function

找到标题和偏移复制某些单元格

1 个答案: