帮忙修改下代码？ - 编程论坛

#2

vc1272013-04-10 08:28

修改下代码？

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

#3

yz10252013-04-10 09:14

乍看之下DLL异常

只有本站会员才能查看附件，请登录

#4

vc1272013-04-10 22:51

帮个忙

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

#5

vc1272013-04-10 23:41

帮个忙

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

#6

vc1272013-04-10 23:57

帮个忙改下代码？

#7

yz10252013-04-11 13:44

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

只有本站会员才能查看附件，请登录

#8

wp2319572013-04-11 14:51

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

#9

vc1272013-04-11 15:05

帮个忙

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

#10

wp2319572013-04-11 15:12

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

#11

vc1272013-04-11 15:27

帮个忙

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

#12

wp2319572013-04-11 15:39

vb貌似无法制作dll吧

#13

vc1272013-04-11 15:44

不可能

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

#14

vc1272013-04-11 15:53

帮个忙搞一下

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

#15

益西翁登2013-04-12 08:05

看不懂

#16

yz10252013-04-15 14:33

以下是引用wp231957在2013-4-11 15:39:24的发言：

vb貌似无法制作dll吧

可以～但是VB做成DLL运行效能～并不会比较快～

#17

yz10252013-04-15 14:37

只有本站会员才能查看附件，请登录

#18

Artless2013-04-15 19:54

LZ的代码？

#19

dsadsad2013-04-15 20:41

代码在哪？

[ 本帖最后由 dsadsad 于 2013-4-17 10:35 编辑 ]

#20

sfadfa2014-11-21 21:22

只有本站会员才能查看附件，请登录

#21

sfadfa2014-11-21 21:42

Sub Macro1()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&, arr, brr()
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    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(xlUp).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

#22

sfadfa2014-11-21 21:53

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

#23

sfadfa2014-11-21 22:07

Sub Macro1()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("F4:I4,N4:O4,Q4:R4,W4:X4")
    Set wb = GetObject(ThisWorkbook.Path & "\B.xls")
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                Set c = .Find(r.Value, , , 1)
                If Not c Is Nothing Then
                    c.Offset(1).Resize(lr).Copy sh.Cells(65536, r.Column).End(xlUp).Offset(1)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

#24

sfadfa2014-11-22 20:10

Sub test1()
    Dim sz(), sz1, sz3, SZ2(), myRegExp As Object
    On Error Resume Next
    Set myRegExp = CreateObject("VBScript.RegExp")
    myRegExp.Global = True
    myRegExp.IgnoreCase = Ture
    myRegExp.Pattern = "[0-9][0-9][0-9][0-9]-[0-9][0-9]?-[0-9][0-9]?-[0-9][0-9]?.xls"
    s = Dir(xlapp.ActiveWorkbook.Path & "\*.xls")
    n = -1
    Do While s <> ""
        If s <> xlapp.ActiveWorkbook.Name Then
        If UCase(s) Like "*[0-9][0-9][0-9][0-9]-[0-9]*-[0-9]*-[0-9]*.XLS" Then
            n = n + 1
            ReDim Preserve sz(n)
            sz(n) = s
            If UCase(s) Like "??[0-9]*" Then
                ReDim Preserve SZ2(n)
                SZ2(n) = Mid(s, 3, 1)
            End If
        End If
        End If
        s = Dir
    Loop

    Set matchs = myRegExp.Execute(Join(sz, ","))
    If matchs.Count = 0 Then MsgBox "请检查文件名！", , "提示": Exit Sub
    ReDim sz1(2, 0)
    For i = 0 To matchs.Count - 1
        ReDim Preserve sz1(2, i)
        sz1(0, i) = matchs.Item(i)
        sz3 = Split(sz1(0, i), "-")
        sz1(1, i) = sz3(0) & "-" & sz3(1) & "-" & sz3(2)
        sz1(2, i) = Split(sz3(3), ".")(0)
    Next i
    xlapp.ScreenUpdating = False
    xlapp.Sheets(3).Activate
    With xlapp.Sheets(3)
        .Columns("A:d").ClearContents
        .[a1].Resize(UBound(sz1, 2) + 1, 3) = xlapp.Transpose(sz1)
        .[d1].Resize(UBound(SZ2) + 1) = xlapp.Transpose(SZ2)

        .[a1].CurrentRegion.Sort Key1:=xlapp.Range("d1"), Order1:=xlAscending, Key2:=xlapp.Range("b1"), Order2:=xlAscending, key3:=xlapp.Range("c1"), _
                                 order3:=xlAscending, Header:=xlGuess
        sz1 = xlapp.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count))
        SZ2 = xlapp.Transpose(.Range("d1:d" & .[d1].CurrentRegion.Rows.Count))

        .Columns("A:d").ClearContents
    End With
    For i = 1 To UBound(sz1)
        For ii = i - 1 To UBound(sz)
            If sz(ii) Like "??" & SZ2(i) & "*" & sz1(i) Then
                temp = sz(i - 1)
                sz(i - 1) = sz(ii)
                sz(ii) = temp
                Exit For
            End If
        Next ii
    Next i

    xlapp.Sheets(1).Activate
    xlapp.Rows("5:65536").Delete
    k = 250
    For i = 0 To UBound(sz)
        With GetObject(xlapp.ActiveWorkbook.Path & "\" & sz(i))
            For ii = 5 To .Sheets(1).Range("A65536").End(xlUp).Row
                If xlapp.ActiveWorkbook.Sheets(1).Range("A65536").End(xlUp).Row = 1 Then
                    mt = 200
                Else
                    mt = 2
                End If
                If .Sheets(1).Range("s" & ii) <> "" Then .Sheets(1).Rows(ii).Copy xlapp.ActiveWorkbook.Sheets(1).Range("A65536").End(xlUp)(mt + k): k = 0
            Next ii
            .Close False
        End With
    Next i

    xlapp.ScreenUpdating = True
End Sub

#25

sfadfa2014-11-22 20:19

Sub Macro1()
    Dim sz(), sz1, SZ2(), myRegExp As Object
    On Error Resume Next
    Set myRegExp = CreateObject("VBScript.RegExp")
    myRegExp.Global = True
    myRegExp.IgnoreCase = Ture
    myRegExp.Pattern = "\d{4}-\d{1,2}-\d{1,2}-\d{1,2}.xls"
    S = Dir(ThisWorkbook.Path & "\*.xls")
    N = -1



    Do While S <> ""
        If UCase(S) Like "*#-*#-*#-[0-9][0-9]*.XLS" Then
            N = N + 1
            ReDim Preserve sz(N)
            sz(N) = S
              If UCase(S) Like "??[0-9]*" Then
                ReDim Preserve SZ2(N)
                SZ2(N) = Mid(S, 3, 1)
            End If
        End If
        S = Dir
    Loop

    Set matchs = myRegExp.Execute(Join(sz, ","))

    If matchs.Count = 0 Then MsgBox "没有数据文件！", , "提示": GoTo out
    ReDim sz1(2, 0)

    For i = 0 To matchs.Count - 1
        ReDim Preserve sz1(2, i)

        sz1(0, i) = matchs.Item(i)
        sz1(1, i) = Left(Replace(matchs.Item(i), ".xls", ""), Len(Replace(matchs.Item(i), ".xls", "")) - 3) '日期

        sz1(2, i) = Right(Replace(matchs.Item(i), ".xls", ""), 2)   '序号
       ' sz1(2, i) = Left(sz1(2, i), Len(sz1(2, i)) - 4)           '序号

    Next i

    Application.ScreenUpdating = False
    Sheet3.Activate
    With Sheet3
        .Columns("A:d").ClearContents
        .[a1].Resize(UBound(sz1, 2) + 1, 3) = Application.Transpose(sz1)
        .[d1].Resize(UBound(SZ2) + 1) = Application.Transpose(SZ2)

        .[a1].CurrentRegion.Sort Key1:=Range("d1"), Order1:=xlAscending, Key2:=Range("b1"), Order2:=xlAscending, key3:=Range("c1"), _
                                 order3:=xlAscending, Header:=xlGuess
        sz1 = Application.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count))
        SZ2 = Application.Transpose(.Range("d1:d" & .[d1].CurrentRegion.Rows.Count))

        .Columns("A:d").ClearContents
    End With
    For i = 1 To UBound(sz1)
        For ii = i - 1 To UBound(sz)
            If sz(ii) Like "??" & SZ2(i) & "*" & sz1(i) Then
                temp = sz(i - 1)
                sz(i - 1) = sz(ii)
                sz(ii) = temp
                Exit For
            End If
        Next ii
    Next i

    '数组sz已经排好了序
    Sheet1.Activate
    Columns("A:I").ClearContents
    For i = 0 To UBound(sz)
        With Workbooks.Open(ThisWorkbook.Path & "\" & sz(i))
            For ii = 1 To .Sheets(1).Range("A65536").End(3).Row
                If ThisWorkbook.Sheets(1).Range("A65536").End(3).Row = 1 Then
                    W = 10
                Else
                    W = 2
                End If
                If .Sheets(1).Range("H" & ii) = "" Then .Sheets(1).Rows(ii).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(W)
            Next ii
            .Close False
        End With
    Next i
out:
    Application.ScreenUpdating = True
End Sub

[ 本帖最后由 sfadfa 于 2014-11-22 21:29 编辑 ]

#26

sfadfa2014-11-22 20:26

Sub Macro1()
    Dim arr, brr, crr(), i As Long, j As Long, k As Long, m As Long, n As Long
    m = xlapp.[b65536].End(xlUp).Row - 5
    arr = xlapp.[b6].Resize(m)
    n = xlapp.[c65536].End(xlUp).Row - 5
    brr = xlapp.[c6].Resize(n, 4)
    ReDim crr(1 To m, 1 To 4)
    For i = 1 To m
        For j = 1 To n
            If brr(j, 1) = arr(i, 1) Then
                For k = 1 To 4
                    crr(i, k) = brr(j, k)
                Next
                Exit For
            End If
        Next
    Next
    xlapp.[c6].Resize(m, 4) = crr
End Sub

#27

sfadfa2014-11-22 20:28

Sub Macro1()
    Dim ar, br(), d As Object, i As Long, m As Long, r1 As Long, s As String
    Set d = CreateObject("Scripting.Dictionary")
    r1 = xlapp.[b65536].End(xlUp).Row
    ar = xlapp.Range("e6:u" & r1)
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 1 To UBound(ar)
        s = Trim(ar(i, 1))
        If Not d.Exists(s) Then
            m = m + 1
            d(s) = m
            br(m, 1) = s
            br(m, 2) = 1
            br(m, 3) = ar(i, 13)
        Else
            br(d(s), 2) = br(d(s), 2) + 1
            br(d(s), 3) = br(d(s), 3) + ar(i, 13)
        End If
    Next
    xlapp.Range("a" & r1 + 11).Resize(m, 3) = br
End Sub

#28

sfadfa2014-11-22 20:41

Sub Macro1()
    Dim d As Object, dic As Object, rng As Excel.Range, arr, brr(), crr, myfile As String, a, i As Long, j As Long, k As Long, l, m, n, s As String, tmp, artmp
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    arr = xlapp.Range("g5:ag" & xlapp.Range("g65536").End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To 3)
    For i = 1 To UBound(arr)
        If Len(arr(i, 13)) Then
            s = "" & arr(i, 1) & "/" & Format(arr(i, 2), "0.00") & "+" & arr(i, 3) & ""
            If Not d.Exists(s) Then
                d(s) = d.Count + 1
                brr(d(s), 1) = s
            End If
            brr(d(s), 2) = brr(d(s), 2) + 1
            dic(s & "|" & arr(i, 13)) = dic(s & "|" & arr(i, 13)) + 1
            k = k + 1: l = l + arr(i, 25): n = n + arr(i, 27)
        End If
        j = j + 1
    Next
    For Each tmp In dic.keys
        artmp = Split(tmp, "|")
        brr(d(artmp(0)), 3) = brr(d(artmp(0)), 3) & "," & dic(tmp) & "|" & artmp(1)
    Next
    s = ""
    For i = 1 To d.Count
        If brr(i, 2) = Val(Mid(brr(i, 3), 2)) Then
            s = s & "；" & brr(i, 2) & "|" & brr(i, 1) & Split(brr(i, 3), "|")(1)
        Else
            s = s & "；" & brr(i, 2) & "|" & brr(i, 1) & ":" & Mid(brr(i, 3), 2)
        End If
    Next
    a = Mid(Replace(s, "|", ""), 2)
    d.RemoveAll
    crr = xlapp.Range("AA5:AA" & xlapp.Range("g65536").End(xlUp).Row)
    For i = 1 To UBound(crr)
        If Len(crr(i, 1)) Then d(crr(i, 1)) = ""
    Next
    m = Join(d.keys, "/")
    xlapp.DisplayAlerts = False
    myfile = Dir(xlapp.ActiveWorkbook.Path & "\*.xls")
    xlapp.Workbooks.Open FileName:=xlapp.ActiveWorkbook.Path & "\" & myfile
    On Error Resume Next
    Set rng = xlapp.InputBox("请选择：", , "$E$20", Type:=8)
    xlapp.Range(rng.Address) = IIf(Len(a) > 0, a & "；" & Format(l, "0.00") & "。", "")
    xlapp.Range(rng.Address).Offset(, -2) = j
    xlapp.Range(rng.Address).Offset(, -1) = k
    xlapp.Range(rng.Address).Offset(, 1) = l
    xlapp.Range(rng.Address).Offset(, 2) = m
    xlapp.Range(rng.Address).Offset(, 3) = n
    xlapp.DisplayAlerts = True
End Sub

[ 本帖最后由 sfadfa 于 2014-11-22 20:47 编辑 ]

#29

sfadfa2014-11-22 21:02

'以下原始统计，对G、H、I列进行计数并写入数组brr中，字典d记下各值位于brr的哪一行，字典dic统计G、H、I、M列进行计数
     For i% = 1 To UBound(arr)
         If Len(arr(i, 7)) Then
            s$ = "(" & arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3) & ")"
            If Not d.exists(s) Then
               d(s) = d.Count + 1  '等效于m=m+1 d(s) =m 两行（m要初始化为0），用于记录下新值s出现的先后顺序1、2、3……
               brr(d(s), 1) = s    '新值s出现的先后顺序依次将s写进数组brr，即brr（1，1）、brr（2，1）、brr（3，1）……
           End If
            brr(d(s), 2) = brr(d(s), 2) + 1   '按s出现的次数依次累加1，即统计s出现了多少次写进数组brr，即brr（1，2）、brr（2，2）、brr（3，2）……
            dic(s & "|" & arr(i, 7)) = dic(s & "|" & arr(i, 7)) + 1   '同上，只是统计的是s & "|" & arr(i, 7)出现了多少次写进字典dic中
        End If
      Next
      '原始统计完成。
     '以下将G、H、I列相同时，M列出现了些什么、出现几次写入数组brr
      For Each tmp In dic.keys   '具体实现过程按f8看本地窗口中artmp和brr的内容变化
          artmp = Split(tmp, "|")    '字典dic的key记录的是s & "|" & arr(i, 7)，现在将他们分开成s与arr(i, 7)写进临时数组artmp中，artmp（0）为s,artmp(1)为arr(i, 7)
          brr(d(artmp(0)), 3) = brr(d(artmp(0)), 3) & "," & dic(tmp) & "个" & artmp(1)  '依据s将arr(i,7)及其出现次数对应写入数组brr中
     Next
      '统计全部完成
     '以下处理统计结果，为输出做准备
     s = ""
      For i = 1 To d.Count
          s = s & ";" & brr(i, 2) & "个" & brr(i, 1) & ":" & Mid(brr(i, 3), 2)  '把brr中的内容串成一串，具体按f8看本地窗口中brr的内容与s的变化过程
     Next
      '输出结果：
     MsgBox Mid(s, 2)

#30

sfadfa2014-11-22 21:03

Sub Macro1()
    Dim j As Long, k As Long, m As Long, sfirst, kmax
    xlapp.ScreenUpdating = False
    k = 行 - 1
    m = Mid(xlapp.Range("e65536").End(xlUp), 5, 5)
    j = 0
    m = m + 1
    sfirst = Left(xlapp.Range("e65536").End(xlUp), 4)
    kmax = xlapp.Range("f65536").End(xlUp).Row
    x = xlapp.Range("a65536").End(xlUp)
    Do
        j = j + 1
        If j > 3 Then
            m = m + 1
            j = 1
        End If
        k = k + 1
        If k > kmax Then Exit Sub
        y = y + 1
        xlapp.Cells(k, 1) = x + y
        xlapp.Cells(k, 2) = xlapp.Range("b65536").End(xlUp)
        xlapp.Cells(k, 3) = xlapp.Range("c65536").End(xlUp)
        xlapp.Cells(k, 4) = xlapp.Range("d65536").End(xlUp)
        xlapp.Cells(k, 5) = sfirst & Format(m, "00000") & j
    Loop While True
    xlapp.ScreenUpdating = True
End Sub

#31

sfadfa2014-11-22 21:06

Sub Macro1()
    Dim d As Object, d1 As Object, arr, i As Long, k As Long, r1 As Long
    xlapp.ScreenUpdating = False
    r1 = xlapp.Cells(xlapp.Rows.Count, 6).End(xlUp).Row
    arr = xlapp.Range("e" & 行 & ":f" & r1)
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    a = Left(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 4)
    b = Mid(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 5, 5)
    For i = 1 To UBound(arr)
        s = arr(i, 2)
        If Not d.Exists(s) Then k = k + 1: d1(s) = b + k
        d(s) = d(s) + 1
        arr(i, 1) = a & Format(d1(s), "00000") & d(s)
    Next
    For i = 1 To UBound(arr)
        s = arr(i, 2)
        If d(s) = 1 Then Mid(arr(i, 1), Len(arr(i, 1)), 1) = "0"
    Next
    xlapp.Range("e" & 行 & ":f" & r1) = arr
    xlapp.ScreenUpdating = True
End Sub

#32

sfadfa2014-11-22 21:18

Sub Macro1()
    Dim arr, i&, j&, lr&, s$
    s = "K"
    With Range("B17:B" & Range("a65536").End(xlUp).Row)
        arr = .Value
        lr = UBound(arr)
        For i = 1 To lr Step 3
            m = m + 1
            n = 0
            For j = i To i + 2
                If j > lr Then Exit For
                n = n + 1
                arr(j, 1) = s & m & n
            Next
        Next
        .Value = arr
    End With
End Sub

#33

sfadfa2014-11-22 21:21

Sub Macro1()
    Dim arr, brr(), wb As Excel.Workbook, sh As Excel.Worksheet, r As Long, i As Long, j As Long, mypath As String
    xlapp.ScreenUpdating = False
    Set sh = xlapp.ActiveSheet
    行 = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    mypath = xlapp.ActiveWorkbook.Path & "\"
    If Dir(mypath & "Book.xls") = "" Then
        MsgBox mypath & "Book.xls 不存在!"
        Exit Sub
    End If
    Set wb = GetObject(mypath & "Book.xls")
    With wb
        With .Worksheets(1)
            r = .UsedRange.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            arr = .Range("a3:bs" & r)
        End With
        .Close False
    End With
    m = 0
    For i = 1 To UBound(arr)
        For j = 1 To arr(i, 36)
            m = m + 1
            ReDim Preserve brr(1 To 9, 1 To m)
            brr(6, m) = arr(i, 4)
            brr(7, m) = arr(i, 63)
            brr(8, m) = arr(i, 54)
            brr(9, m) = arr(i, 55)
        Next
    Next
    sh.Range("a" & 行).Resize(UBound(brr, 2), UBound(brr)) = xlapp.Transpose(brr)
    xlapp.ScreenUpdating = True
End Sub

#34

sfadfa2014-11-22 21:49

Private Sub CommandButton1_Click()
    Dim arr, i&, j&, d As Object
    Set d = CreateObject("scripting.dictionary")
    d(0) = "A"
    d(1) = "B"
    d("03") = "C"
    d("13") = "D"
    d("04") = "E"
    d("14") = "F"
    d("05") = "X"
    d("15") = "Y"
    d("25") = "Z"
    arr = [m5].CurrentRegion
    For i = 1 To UBound(arr)
        If d.Exists(arr(i, 1)) Then
            arr(i, 1) = d(arr(i, 1))
            arr(i, 2) = arr(i, 2) & "/" & arr(i, 2)
            For j = 3 To 5
                arr(i, j) = d(arr(i, j) & j)
            Next
        End If
    Next
    [m5].CurrentRegion = arr
End Sub

#35

sfadfa2014-11-22 21:50

Private Sub CommandButton1_Click()
    Dim arr, i&, j&, d As Object
    Set d = CreateObject("scripting.dictionary")
    d(0) = "A"
    d(1) = "B"
    d("03") = "C"
    d("13") = "D"
    d("04") = "E"
    d("14") = "F"
    d("05") = "X"
    d("15") = "Y"
    d("25") = "Z"
    arr = [m5].CurrentRegion
    For i = 1 To UBound(arr)
        If d.Exists(arr(i, 1)) Then arr(i, 1) = d(arr(i, 1))
        If InStr(arr(i, 2), "/") = 0 Then arr(i, 2) = arr(i, 2) & "/" & arr(i, 2)
        For j = 3 To 5
            If d.Exists(arr(i, j) & j) Then arr(i, j) = d(arr(i, j) & j)
        Next
    Next
    [m5].CurrentRegion = arr
End Sub

原单元格值是数字的，直接使用的不用双引号，单元格值用“&”连接起来后就变成了字符串，而字符串常数表示方法要用用双引号
单元格值为1，列号为3，就是1&3="13"

[ 本帖最后由 sfadfa 于 2014-11-22 21:54 编辑 ]

#36

sfadfa2014-11-22 21:59

Sub Macro1()
i = Range("A65536").End(xlUp).Row
Set m = Range("B65536").End(xlUp)
ReDim arr(1 To (i - m.Row), 1 To 1)
k = Left(m.Value, 4)
a = Mid(m.Value, 5, Len(m.Value) - 5)
L = Len(a)
a = a + 1
For j = 1 To i - m.Row
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
    If Len(a) < L Then
        For x = 1 To L - Len(a)
            a = "0" & a
        Next
    End If
    arr(j, 1) = k & a & n
Next
m.Offset(1, 0).Resize(j - 1, 1) = arr
End Sub

#37

sfadfa2014-11-22 22:02

Private Sub CommandButton1_Click()
Dim arr(1 To 36), i&
arr(1) = Left([b16], Len([b16]) - 1) & 1
For i = 2 To UBound(arr)
  arr(i) = Left(arr(i - 1), Len(arr(i - 1)) - 3) & Format(Mid(arr(i - 1), Len(arr(i - 1)) - 2) + 1, "000")
  If Right(arr(i), 1) > 3 Then
  arr(i) = Left(arr(i - 1), Len(arr(i - 1)) - 3) & Format(Mid(arr(i - 1), Len(arr(i - 1)) - 2) + 8, "000")
  End If
Next
[e5].Resize(UBound(arr), 1) = Application.Transpose(arr)
End Sub

#38

sfadfa2014-11-22 22:05

Sub test()
    Dim a, i, j, num, arr
    a = Sheets(1).Cells(60000, 1).End(xlUp).Row - 4
    ReDim arr(1 To a, 1 To 1)
    num = 32100206
    For i = 1 To a Step 3
        num = num + 1
        For j = 1 To 3
            If i + j - 2 < a Then arr(i + j - 1, 1) = "K" & num & j
        Next j
    Next i
    Sheets(1).Cells(5, 2).Resize(a) = arr
End Sub

#39

sfadfa2014-11-22 22:07

Sub Macro1()
i = Range("A65536").End(xlUp).Row
ReDim arr(1 To i - 4, 1 To 1)
box = InputBox("请输入第一个标题编码：")
If box = "" Then End
n = Right(box, 1)
If n > 3 Then
    MsgBox "编码错误，尾数不能大于3！", vbOKOnly
    End
End If
k = Left(box, 1)
a = Mid(box, 2, Len(box) - 2)
For j = 1 To i - 4
    arr(j, 1) = k & a & n
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
Next
Range("B5:B" & i) = arr
End Sub

#40

sfadfa2014-11-22 22:09

Sub Macro1()
i = Range("A65536").End(xlUp).Row
Set m = Range("B65536").End(xlUp)
ReDim arr(1 To (i - m.Row), 1 To 1)
n = Right(m.Value, 1)
k = Left(m.Value, 4)
a = Mid(m.Value, 5, Len(m.Value) - 5)
L = Len(a)
For j = 1 To i - m.Row
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
    If Len(a) < L Then
        For x = 1 To L - Len(a)
            a = "0" & a
        Next
    End If
    arr(j, 1) = k & a & n
Next
m.Offset(1, 0).Resize(j - 1, 1) = arr
End Sub

#41

sfadfa2014-11-22 22:15

Sub Macro1()
i = Range("A65536").End(xlUp).Row
Set m = Range("B65536").End(xlUp)
ReDim arr(1 To (i - m.Row), 1 To 1)
k = Left(m.Value, 4)
a = Mid(m.Value, 5, Len(m.Value) - 5)
L = Len(a)
a = a + 1
For j = 1 To i - m.Row
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
    If Len(a) < L Then
        For x = 1 To L - Len(a)
            a = "0" & a
        Next
    End If
    arr(j, 1) = k & a & n
Next
m.Offset(1, 0).Resize(j - 1, 1) = arr
End Sub