見出しとオフセットをコピーする特定のセルをコピーする

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