Excel макрос, поиск по возвращению строки следующего значения ячейки

Question

У меня есть этот макрос уже работает:

Sub ListSheetsValuesAreOn() 
    Dim X As Long, Data As Variant, Uniques As String, SH As Worksheet, NewSH As Worksheet 
    With CreateObject("Scripting.Dictionary") 
    For Each SH In Worksheets 
     Data = Application.Transpose(SH.Range("C23", SH.Cells(Rows.Count, "C").End(xlUp))) 
     For X = 1 To UBound(Data) 
     If IsEmpty(.Item(Data(X))) Then 
      .Item(Data(X)) = Data(X) & "|" & SH.Name 
     ElseIf Data(X) = Split(.Item(Data(X)), "|")(0) And _ 
       Not .Item(Data(X)) Like "*|*" & SH.Name & "*" Then 
      .Item(Data(X)) = .Item(Data(X)) & ", " & SH.Name 
     End If 
     Next 
    Next 
    Sheets.Add After:=Sheets(Sheets.Count) 
    Set NewSH = ActiveSheet 
    NewSH.Range("A1").Resize(.Count) = Application.Transpose(.Items) 
    End With 
    NewSH.Name = "Result Sheet" 
    NewSH.Columns("A").TextToColumns , xlDelimited, , , 0, 0, 0, 0, 1, "|" 
    NewSH.Columns("A:B").AutoFit 
End Sub 

Что делает этот сценарий является: считанными значения в колонке C и поиск всех книг, чтобы найти эти значения. Возврат значений и листов, на которых они были найдены. Но я хочу вернуться не каждое значение в C, но следующий в колонке D. Пример:

Sheets 1...n         Expected output (new sheet) 

    C  | D         A  |  B 

    item 1|description of item 1  description of item 1|1,4,6 

    item 2|description of item 2  description of item 2|3,7,11,12 

    ... | ....       ....    | ..... 

    item m|description of item m  description of item m| 5,9,15,24 

Answer 1

Пожалуйста, попробуйте это:

Sub Answer() 

    Dim dict As Object 
    Dim Data As Variant 
    Dim ws As Worksheet 
    Dim rng As Range 



    Set dict = CreateObject("Scripting.Dictionary") 
    With dict 
     For Each SH In Worksheets 
     Data = Application.Transpose(SH.Range("C23", SH.Cells(Rows.Count, "D").End(xlUp))) 
     For X = LBound(Data, 2) To UBound(Data, 2) 

      If IsEmpty(.Item(Data(1, X))) Then 
       .Item(Data(1, X)) = Data(2, X) + "|" + SH.Name 
       '.Item(Data(2, X)) = .Item(Data(1, X)) 
      ElseIf Split((dict.Item(Data(1, X))), "|")(0) = Split((Data(2, X)), "|")(0) Then 
       .Item(Data(1, X)) = .Item(Data(1, X)) + ", " + SH.Name 
      End If 
     Next X 
    Next 
    Sheets.Add After:=Sheets(Sheets.Count) 
    Set NewSH = ActiveSheet 
    NewSH.Range("A1").Resize(.Count) = Application.Transpose(.Items) 

    End With 
    NewSH.Name = "Result Sheet" 
    NewSH.Columns("A").TextToColumns , xlDelimited, , , 0, 0, 0, 0, 1, "|" 
    NewSH.Columns("A:B").AutoFit 
End Sub 

Answer 2

Несколько предостережений ниже решения, я использую колонки А и В в качестве источников, мои данные не нуждающихся в транспозиции.

Sub Answer() 

    Dim dict As Object 
    Dim Data As Variant 
    Dim ws As Worksheet 
    Dim rng As Range 



    Set dict = CreateObject("Scripting.Dictionary") 
    With dict 
     For Each SH In Worksheets 
     Data = Application.Transpose(SH.Range("A1", SH.Cells(Rows.Count, "B").End(xlUp))) 
     For X = LBound(Data, 1) To UBound(Data, 1) 

      If IsEmpty(.Item(Data(X, 1))) Then 
       .Item(Data(X, 1)) = Data(X, 2) & "|" & SH.Name 
      ElseIf Data(X, 1) = Split(.Item(Data(X, 1)), "|")(0) And _ 
        Not .Item(Data(X, 2)) Like "*|*" & SH.Name & "*" Then 
       .Item(Data(X, 1)) = .Item(Data(X, 2)) & ", " & SH.Name 
      End If 
     Next X 
     Next ' For Each 
     ... 
    End With 
    ... 
End Sub