数据的引用和转置

laojiu369

求助：

1、A2单元格中，有若干组数字。【H列10组数字中的一部分，数量不定（对应依据中黄底色部分）】
2、按下按钮，F2以下单元格中依次显示所对应的蓝底色部分数字【对应依据中蓝底色部分】
3、最终效果如F列所示。用VBA代码来实现。
4、无底色部分只起说明作用，无需显示。
预谢各位老师出手相助！

详情见附件和图片。
新建 Microsoft Excel 工作表.rar (27.28 KB, 下载次数: 5)

2024-1-28 23:39 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.29
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Me.Cells(Rows.Count, "h").End(3).Row
   
4.     arr = Me.[h6].Resize(r - 5, 4)
   
5.     For i = 1 To UBound(arr)
   
6.         s = CStr(arr(i, 1))
   
7.         d(s) = Array(arr(i, 2), arr(i, 3), arr(i, 4))
   
8.     Next
   
9.     b = Split(Trim(Me.[a2]))
   
10.     ReDim brr(1 To 1000, 1 To 1)
    
11.     For x = 0 To UBound(b)
    
12.         s = b(x)
    
13.         If d.exists(s) Then
    
14.         t = d(s)
    
15.             For k = 0 To UBound(t)
    
16.                 m = m + 1
    
17.                 brr(m, 1) = t(k)
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     Me.Columns("F:F") = ""
    
22.     Me.Columns(6).NumberFormatLocal = "@"
    
23.     Me.[f2].Resize(m, 1) = brr
    
24.     Set d = Nothing
    
25.     MsgBox "OK！"
    
26. End Sub
    

复制代码

清风竹-

请看附件。

ykcbf1100

附件供参考。。。

准提部林

Sub Test_A1() 'by.准提部林
Dim Arr, Brr, TT$, i&, j%, N&
Arr = Range([k6], [h65536].End(3))
ReDim Brr(1 To UBound(Arr) * 3, 1)
TT = "  " & Range("a2") & " "
For i = 1 To UBound(Arr)
    If InStr(TT, " " & Arr(i, 1) & " ") > 1 Then
       For j = 2 To 4
           N = N + 1
           Brr(N, 0) = N
           Brr(N, 1) = "'" & Arr(i, j)
       Next
    End If
Next i
[e2].Resize(N, 2) = Brr
End Sub

laojiu369

两位老师辛苦了！
这是我所需程序中的一部分。移植到总表中，发现一些问题，还请两位老师学家修改。
1、类模块我不熟悉，不会使用，请改为普通模块，或者提示一下怎样使用类模块。
2、最终结果只显示在F列，E列不显示任何内容。
3、新的要求：请修改为只显示在F2单元格，以数据+空格形式显示，不再转置为竖列逐格显示。
还请老师费心相助。

laojiu369

还有，菜鸟一个，只会评分，不会送花，请指教。
好人一生平安！

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, k&, r&
   
    Application.ScreenUpdating = False

    With Range("H6", Cells(Rows.Count, "K").End(xlUp))
        ar = .Columns("A:B")
        For i = 1 To UBound(ar)
            ar(i, 2) = .Rows(i)
        Next i
    End With
    br = Split([A2].Value)
    ReDim cr(1 To (UBound(br) + 1) * (UBound(ar) - 1), 0)
    For j = 0 To UBound(br)
        For i = 1 To UBound(ar)
            If ar(i, 1) = br(j) Then
                For k = 2 To UBound(ar(i, 2), 2)
                    r = r + 1
                    cr(r, 0) = ar(i, 2)(1, k)
                Next k
                Exit For
            End If
        Next i
    Next j
   
    Columns("F").ClearContents
    [F2].Resize(r) = cr
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

ykcbf1100

laojiu369 发表于 2024-1-29 16:53
还有，菜鸟一个，只会评分，不会送花，请指教。
好人一生平安！

点击楼层右下角的“评分”就可以送花了。
评分——选择小花数量——选择评分理由——通知作者——确定。
送花完毕！