Excel Macro, Search by Row returns the value of the next cell

advertisements

I have this Macro already working:

    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

What this script does is: Read values in C column and search all the workbook to find these values. Returning the values and the sheets where they've been found. But I want to return not each value in C but the next one in column D. Example:

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


Please try this one:

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