帮忙修改下代码？


[ 本帖最后由 vc127 于 2013-4-11 19:54 编辑 ]

修改下代码？

[ 本帖最后由 vc127 于 2013-4-11 19:52 编辑 ]

乍看之下DLL异常

帮个忙

[ 本帖最后由 vc127 于 2013-4-11 19:53 编辑 ]

帮个忙

[ 本帖最后由 vc127 于 2013-4-11 19:53 编辑 ]

帮个忙改下代码？

开起来重新编译～貌似无缘无故就好了～

dll代码咋修改啊  你的想办法弄到源码才可以

帮个忙

[ 本帖最后由 vc127 于 2013-4-11 19:53 编辑 ]

Sub aaa()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr&
    Dim a, b, d As Object, i&, arr, brr()
    Set d = CreateObject("scripting.dictionary")
    a = Array("序号", "项目")
    b = Array("编号", "类型")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("A4:X4")
    Set wb = GetObject(ThisWorkbook.Path & "\B.xls")
    j = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    With wb.Sheets(1)
        lr = .[a65536].End(3).Row - 2
        With .Rows(2)
            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(j, r.Column).Resize(lr * 3).Value = brr
                    End If
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub