能不能把下面vb代码转换成代码？

Sub test()
    Dim wb As Excel.Workbook, sh As Excel.Worksheet, c As Excel.Range, r As Excel.Range, rng As Excel.Range, lr As Long, l As Long, m As Long
    Dim a, b, t, d As Object, i As Long, arr, brr()
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "d")
    b = Array("c", "e")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    xlapp.ScreenUpdating = False
    Set sh = xlapp.ActiveSheet
    Set rng = xlapp.Range("A3:W3").Value
    Set wb = GetObject(xlapp.ActiveWorkbook.Path & "\Book.xls")
    k= sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    With wb.Sheets(1)
        lr = .Range("b65536").End(Xlup).Row - 1
        With .Rows(1)
            For Each r In rng
                t = d(r.Value)
                If t <> "" Then
                    Set c = .Find(d(r.Value), , , 1)
                    If Not c Is Nothing Then
                        arr = c.Offset(1).Resize(lr + 1).Value
                        ReDim brr(1 To lr * 3, 1 To 1)
                        m = 0
                        For i = 1 To lr
                            For l = m + 1 To m + 3
                                brr(l, 1) = arr(i, 1)
                            Next
                            m = m + 3
                        Next
                        sh.Cells(k, r.Column).Resize(lr * 3).Value = brr
                    End If
                End If
            Next
        End With
    End With
    wb.Close False
    xlapp.ScreenUpdating = True
End Sub

[此贴子已经被作者于2022-6-26 19:32编辑过]

帮个忙？？

[此贴子已经被作者于2022-7-6 11:20编辑过]

在中添加一个纯代码模块文件，把你的代码复制进去，然后改动有错误提示的地方，就行了