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

以下解决方案的几点注意事项，我使用A列和B列作为源，我的数据不需要换位。

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

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("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

Excel宏，按行搜索返回下一个单元格的值

2 个答案: