设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 培训班 › Excel VBA字典班 › 作业参考代码
12下一页
返回列表 发新帖
查看: 6214|回复: 15

[习题] 作业参考代码

[复制链接]
wcymiss
发表于 2012-1-11 16:46 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 wcymiss 于 2012-1-13 08:13 编辑

仅为完成花花的任务而写的，{:3712:}，大家不看也无妨。。
作业一.rar (130.79 KB, 下载次数: 109)

评分

参与人数 3 +118 金币 +60 收起 理由
windimi007 + 18 很给力!
liuts + 50 + 30 赞一个!
liuguansky + 50 + 30 吴姐偶像，辛苦了。

查看全部评分

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 16:53 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 wcymiss 于 2012-1-11 17:08 编辑

作业一_必做：
  1. Sub 作业一_必做()
  2.     '要求不得定义大容量数组
  3.     Dim arr, arr1(), arr2(), arr3()
  4.     Dim i1 As Long, i2 As Long, i3 As Long, i As Long
  5.     arr = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row).Value
  6.     For i = 1 To UBound(arr)
  7.         If arr(i, 2) >= 3000 Then
  8.             i1 = i1 + 1
  9.             ReDim Preserve arr1(1 To 2, 1 To i1)
  10.             arr1(1, i1) = arr(i, 1)
  11.             arr1(2, i1) = arr(i, 2)
  12.         ElseIf arr(i, 2) >= 2000 Then
  13.             i2 = i2 + 1
  14.             ReDim Preserve arr2(1 To 2, 1 To i2)
  15.             arr2(1, i2) = arr(i, 1)
  16.             arr2(2, i2) = arr(i, 2)
  17.         Else
  18.             i3 = i3 + 1
  19.             ReDim Preserve arr3(1 To 2, 1 To i3)
  20.             arr3(1, i3) = arr(i, 1)
  21.             arr3(2, i3) = arr(i, 2)
  22.         End If
  23.     Next
  24.     Range("d3", Cells(Rows.Count, Columns.Count)).ClearContents
  25.     Range("d3").Resize(i3, 2) = Application.Transpose(arr3)
  26.     Range("f3").Resize(i2, 2) = Application.Transpose(arr2)
  27.     Range("h3").Resize(i1, 2) = Application.Transpose(arr1)
  28. End Sub
复制代码
回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 17:09 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 wcymiss 于 2012-1-11 17:10 编辑

作业一_选做：
  1. Sub 作业一_选做()
  2.     Dim arr, brr(1 To 1000), crr(1 To 1000, 1 To 1)
  3.     Dim i As Long, n As Long
  4.     arr = Range([A1], Cells([A65536].End(3).Row, 1))
  5.     For i = 1 To UBound(arr)
  6.         If IsEmpty(brr(arr(i, 1))) Then
  7.             n = n + 1
  8.             crr(n, 1) = arr(i, 1)
  9.             brr(arr(i, 1)) = 1
  10.         End If
  11.     Next
  12.     Range("c:c").ClearContents
  13.     Range("c1").Resize(n, 1) = crr
  14. End Sub
复制代码

回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 17:13 | 显示全部楼层
本帖最后由 wcymiss 于 2012-1-11 19:56 编辑

作业二_必做一：
  1. Function Jcarr(ByVal a As Variant, Optional ByVal b As Long = 1) As String
  2.     '必做一
  3.     '一字典+数组
  4.     If IsArray(a) Then
  5.         Dim D As Object, Jc As String
  6.         Dim i As Long, j As Long, m As Long
  7.         Dim arr, brr() As Long, di, dk, ar
  8.         Set D = CreateObject("scripting.dictionary")
  9.         arr = a '数组赋值
  10.         For Each ar In arr
  11.             D(ar) = D(ar) + 1 '字典key为每个数字，item为数字出现的次数
  12.         Next
  13.         ReDim brr(UBound(arr))
  14.         di = D.Items
  15.         For i = 0 To UBound(di)
  16.             brr(di(i)) = 1 '用数组下标对次数去重及排序
  17.         Next
  18.         For i = UBound(brr) To 1 Step -1
  19.             If brr(i) > 0 Then
  20.                 m = m + 1
  21.                 If m = b Then Exit For
  22.             End If
  23.         Next
  24.         dk = D.keys
  25.         For j = 0 To UBound(di)
  26.             If di(j) = i Then Jc = Jc & "|" & dk(j)
  27.         Next
  28.         Jc = Mid(Jc, 2)
  29.         Set D = Nothing
  30.     Else
  31.         Jc = a.Value
  32.     End If
  33.     Jcarr = Jc
  34. End Function
复制代码

  1. Function Jcdic(ByVal a As Variant, Optional ByVal b As Long = 1) As String
  2.     '必做一
  3.     '二字典
  4.     If IsArray(a) Then
  5.         Dim d1 As Object, d2 As Object, Jc As String
  6.         Dim i As Long, j As Long, m As Long
  7.         Dim arr, brr() As Long, di, dk, ar
  8.         Set d1 = CreateObject("scripting.dictionary")
  9.         Set d2 = CreateObject("scripting.dictionary")
  10.         arr = a
  11.         For Each ar In arr
  12.             d1(ar) = d1(ar) + 1
  13.         Next
  14.         di = d1.Items
  15.         dk = d1.keys
  16.         For i = 0 To UBound(di)
  17.            d2(di(i)) = d2(di(i)) & "|" & dk(i)
  18.         Next
  19.         Jc = Mid(d2(Application.Large(d2.keys, b)), 2)
  20.     Else
  21.         Jc = a.Value
  22.     End If
  23.     Set d1 = Nothing
  24.     Set d2 = Nothing
  25.     Jcdic = Jc
  26. End Function
复制代码

回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 17:15 | 显示全部楼层
本帖最后由 wcymiss 于 2012-1-11 20:02 编辑

作业二_必做二：
  1. Sub 作业二_必做二()
  2.     Dim D As Object, sh As Worksheet
  3.     Dim co As Integer, i As Long, arr
  4.     Set D = CreateObject("scripting.dictionary")
  5.     co = Sheets("必做二").Tab.ColorIndex
  6.     For Each sh In ThisWorkbook.Sheets
  7.         If sh.Name <> "必做二" Then
  8.             If sh.Tab.ColorIndex = co Then
  9.                 arr = sh.Range("a2:b" & sh.Cells(Rows.Count, 1).End(3).Row)
  10.                 For i = 1 To UBound(arr)
  11.                     D(arr(i, 1)) = D(arr(i, 1)) + Val(arr(i, 2))
  12.                 Next
  13.             End If
  14.         End If
  15.     Next
  16.     With Sheets("必做二")
  17.         .Range("a:b").ClearContents
  18.         .Range("a1:b1") = Array("产品型号", "数量")
  19.         .Range("a2").Resize(D.Count) = Application.Transpose(D.keys)
  20.         .Range("b2").Resize(D.Count) = Application.Transpose(D.Items)
  21.     End With
  22.     Set D = Nothing
  23.     Set sh = Nothing
  24. End Sub
复制代码

回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 17:16 | 显示全部楼层
作业二_选做一:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     '作业二_选做一
  3.     If Target.Count > 1 Then Exit Sub
  4.     If Target.Address <> "$E$1" Then Exit Sub
  5.     Dim arr, i As Long, s As String, brr, tv As String
  6.     arr = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row).Formula
  7.     tv = Target.Value
  8.     For i = 1 To UBound(arr)
  9.         If arr(i, 1) = tv Then
  10.             s = s & "+" & arr(i, 2)
  11.         End If
  12.     Next
  13.     Application.EnableEvents = False
  14.     Range("e2:e" & Rows.Count).ClearContents
  15.     If s <> "" Then
  16.         s = Mid(Replace(s, "=", ""), 2)
  17.         brr = Split(s, "+")
  18.         Range("e2").Resize(UBound(brr) + 1) = Application.Transpose(brr)
  19.     End If
  20.     Application.EnableEvents = True
  21. End Sub
复制代码

回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 17:17 | 显示全部楼层
本帖最后由 wcymiss 于 2012-1-11 17:17 编辑

作业二_选做二：
  1. Sub 作业二_选做二()
  2.     Dim arr, i As Long, brr(), crr()
  3.     arr = Sheets("选做二数据源").UsedRange
  4.     r = UBound(arr)
  5.     ReDim brr(1 To 10, 1 To UBound(arr, 2))
  6.     ReDim crr(1 To r)
  7.     For i = 1 To 10
  8.         k = Int(Rnd * r + 1)
  9.         If IsEmpty(crr(k)) Then
  10.             For j = 1 To UBound(brr, 2)
  11.                 brr(i, j) = arr(k, j)
  12.             Next
  13.             crr(k) = 1
  14.         Else
  15.             i = i - 1
  16.         End If
  17.     Next
  18.     With Sheets("选做二")
  19.         .Cells.ClearContents
  20.         .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
  21.     End With
  22. End Sub
复制代码

回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 17:21 | 显示全部楼层
本帖最后由 wcymiss 于 2012-1-11 21:19 编辑

作业二_附加题：
  1. Sub 作业二_附加题()
  2.     '字典拆分，支持乱序
  3.     '代码效果：如果选择不删除，则拆分的记录添加在原表其后。
  4.     Dim D As Object
  5.     Dim arr, trr, dk, di, x, brr, irr
  6.     Dim i As Long, j As Long, k As Long, m As Integer
  7.     Application.ScreenUpdating = False
  8.     Application.DisplayAlerts = False
  9.     Set D = CreateObject("scripting.dictionary")
  10.     With Sheets("附加题")
  11.         trr = .Range("a1:s1")
  12.         arr = .Range("a2:s" & .Cells(Rows.Count, 14).End(3).Row)
  13.     End With
  14.     For i = 1 To UBound(arr)
  15.         D(arr(i, 14)) = D(arr(i, 14)) & vbCr & i
  16.     Next
  17.     If D.Count < 2 Then
  18.         MsgBox "无数据或委托单位只有一种，不需拆分本工作表"
  19.         Exit Sub
  20.     End If
  21.     dk = D.keys
  22.     di = D.items
  23.     For i = 0 To UBound(dk)
  24.         irr = Split(di(i), vbCr) 'irr(0)是空值,其余为委托单位的行号
  25.         ReDim brr(1 To UBound(irr), 1 To 19)
  26.         For j = 1 To UBound(irr)
  27.             For k = 1 To 19
  28.                 brr(j, k) = arr(irr(j), k)
  29.             Next
  30.         Next
  31.         On Error Resume Next
  32.         x = Sheets(dk(i)).Range("a1")
  33.         If Err.Number = 0 Then
  34.             m = MsgBox("Sheets(" & dk(i) & ")已存在,要删除吗？", vbYesNo, "警告")
  35.             If m = 6 Then
  36.                 With Sheets(dk(i))
  37.                     .Cells.ClearContents
  38.                     .Range("a1").Resize(1, UBound(trr, 2)) = trr
  39.                 End With
  40.             End If
  41.         Else
  42.             Err.Clear
  43.             Sheets.Add after:=Sheets(Sheets.Count)
  44.             With ActiveSheet
  45.                 .Name = dk(i)
  46.                 .Range("a1").Resize(1, UBound(trr, 2)) = trr
  47.             End With
  48.         End If
  49.         Sheets(dk(i)).Cells(Rows.Count, 14).End(3).Offset(1, -13).Resize(UBound(brr), UBound(brr, 2)) = brr
  50.     Next
  51.     Set D = Nothing
  52.     Application.DisplayAlerts = True
  53.     Application.ScreenUpdating = True
  54. End Sub
复制代码

回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-11 23:34 | 显示全部楼层
本帖最后由 wcymiss 于 2012-1-12 12:11 编辑

作业三_必做一：
效果一用了三种方法，效果二就只用一种了，其实效果一与效果二差不多，区别在于结果数组的行列号构造。
  1. Sub 作业三_必做一_效果一_数组()
  2.     '数组，数据源需按仓库名称排序。
  3.     Dim arr, trr, brr()
  4.     Dim i As Long, n1 As Long, n2 As Long, j As Long, n As Long, k As Long, x As Long, y As Long
  5.     With Sheets("必做一")
  6.         arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row + 1) '数据源
  7.         trr = .Range("a1:e1") '标题
  8.         ReDim brr(1 To UBound(arr), 1 To (UBound(arr) \ 4) * 5 + 5) '定义大数组
  9.         n1 = 1 '仓库名称的起始位置
  10.         k = 1 '结果数组行号
  11.         For i = 2 To UBound(arr)
  12.             If arr(i, 1) <> arr(i - 1, 1) Then
  13.                 n2 = i - 1 '仓库名称的结束位置
  14.                 n = 0 '仓库名称的序号
  15.                 brr(k, 1) = trr(1, 1)
  16.                 brr(k, 2) = trr(1, 2)
  17.                 brr(k, 3) = trr(1, 3)
  18.                 brr(k, 4) = trr(1, 4)
  19.                 brr(k, 5) = trr(1, 5)
  20.                 For j = n1 To n2
  21.                     x = n Mod 4 + 1 + k '结果数组的行号
  22.                     y = (n \ 4) * 5 '结果数组的列号
  23.                     If ymax < y Then ymax = y '最大列号
  24.                     brr(x, y + 1) = arr(j, 1)
  25.                     brr(x, y + 2) = arr(j, 2)
  26.                     brr(x, y + 3) = arr(j, 3)
  27.                     brr(x, y + 4) = arr(j, 4)
  28.                     brr(x, y + 5) = arr(j, 5)
  29.                     n = n + 1
  30.                 Next
  31.                 n1 = i
  32.                 k = k + 5
  33.             End If
  34.         Next
  35.         .Range("g1", .Cells(Rows.Count, Columns.Count)).ClearContents
  36.         For j = 9 To ymax + 9 Step 5
  37.             .Cells(1, j).Resize(i, 1).NumberFormat = "@"
  38.         Next
  39.         .Range("g1").Resize(i, ymax + 5) = brr
  40.     End With
  41. End Sub
复制代码

  1. Sub 作业三_必做一_效果一_字典嵌套()
  2.     '字典嵌套，支持乱序
  3.     Dim d As Object
  4.     Dim arr, trr, brr(), dk, ddk
  5.     Dim i As Long, n As Long, k As Long, x As Long, y As Long, ymax As Long
  6.     Set d = CreateObject("scripting.dictionary")
  7.     With Sheets("必做一")
  8.         arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row) '数据源
  9.         trr = .Range("a1:e1") '标题
  10.         ReDim brr(1 To UBound(arr), 1 To (UBound(arr) \ 4) * 5 + 5) '定义大数组
  11.         For i = 1 To UBound(arr)
  12.             If d.exists(arr(i, 1)) Then
  13.                 d(arr(i, 1))(i) = 1
  14.             Else
  15.                 Set d(arr(i, 1)) = CreateObject("scripting.dictionary") '父字典key为仓库名称
  16.                 d(arr(i, 1))(i) = 1 '子字典key为行号
  17.             End If
  18.         Next
  19.         dk = d.keys '仓库名称
  20.         For i = 0 To UBound(dk)
  21.             ddk = d(dk(i)).keys '每种仓库名称的行号
  22.             k = i * 5 + 1 '结果数组的起始行
  23.             brr(k, 1) = trr(1, 1)
  24.             brr(k, 2) = trr(1, 2)
  25.             brr(k, 3) = trr(1, 3)
  26.             brr(k, 4) = trr(1, 4)
  27.             brr(k, 5) = trr(1, 5)
  28.             For n = 0 To UBound(ddk)
  29.                 x = n Mod 4 + 1 + k '结果数组的行号
  30.                 y = (n \ 4) * 5 '结果数组的列号
  31.                 If ymax < y Then ymax = y '最大列号
  32.                 brr(x, y + 1) = arr(ddk(n), 1)
  33.                 brr(x, y + 2) = arr(ddk(n), 2)
  34.                 brr(x, y + 3) = arr(ddk(n), 3)
  35.                 brr(x, y + 4) = arr(ddk(n), 4)
  36.                 brr(x, y + 5) = arr(ddk(n), 5)
  37.             Next
  38.         Next
  39.         .Range("g1", .Cells(Rows.Count, Columns.Count)).ClearContents
  40.         For i = 9 To ymax + 9 Step 5
  41.             .Cells(1, i).Resize(k + 4, 1).NumberFormat = "@"
  42.         Next
  43.         .Range("g1").Resize(k + 4, ymax + 5) = brr
  44.     End With
  45.     Set d = Nothing
  46. End Sub
复制代码

  1. Sub 作业三_必做一_效果一_字典()
  2.     '字典，支持乱序
  3.     Dim d As Object
  4.     Dim arr, trr, brr(), dk, di, irr
  5.     Dim i As Long, n As Long, k As Long, x As Long, y As Long, ymax As Long
  6.     Set d = CreateObject("scripting.dictionary")
  7.     With Sheets("必做一")
  8.         arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row) '数据源
  9.         trr = .Range("a1:e1") '标题
  10.         ReDim brr(1 To UBound(arr), 1 To (UBound(arr) \ 4) * 5 + 5) '定义大数组
  11.         For i = 1 To UBound(arr)
  12.             d(arr(i, 1)) = d(arr(i, 1)) & "," & i '字典key为仓库名称，item为行号的连接
  13.         Next
  14.         dk = d.keys '仓库名称
  15.         di = d.items
  16.         For i = 0 To UBound(dk)
  17.             irr = Split(di(i), ",")
  18.             k = i * 5 + 1 '结果数组的起始行
  19.             brr(k, 1) = trr(1, 1)
  20.             brr(k, 2) = trr(1, 2)
  21.             brr(k, 3) = trr(1, 3)
  22.             brr(k, 4) = trr(1, 4)
  23.             brr(k, 5) = trr(1, 5)
  24.             For n = 1 To UBound(irr)
  25.                 x = (n - 1) Mod 4 + 1 + k '结果数组的行号
  26.                 y = ((n - 1) \ 4) * 5 '结果数组的列号
  27.                 If ymax < y Then ymax = y '最大列号
  28.                 brr(x, y + 1) = arr(irr(n), 1)
  29.                 brr(x, y + 2) = arr(irr(n), 2)
  30.                 brr(x, y + 3) = arr(irr(n), 3)
  31.                 brr(x, y + 4) = arr(irr(n), 4)
  32.                 brr(x, y + 5) = arr(irr(n), 5)
  33.             Next
  34.         Next
  35.         .Range("g1", .Cells(Rows.Count, Columns.Count)).ClearContents
  36.         For i = 9 To ymax + 9 Step 5
  37.             .Cells(1, i).Resize(k + 4, 1).NumberFormat = "@"
  38.         Next
  39.         .Range("g1").Resize(k + 4, ymax + 5) = brr
  40.     End With
  41.     Set d = Nothing
  42. End Sub
复制代码

  1. Sub 作业三_必做一_效果二()
  2.     Dim d As Object
  3.     Dim arr, trr, brr(), dk, di, irr
  4.     Dim i As Long, n As Long, k As Long, x As Long, y As Long, ymax As Long
  5.     Set d = CreateObject("scripting.dictionary")
  6.     With Sheets("必做一")
  7.         arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row)
  8.         trr = .Range("a1:e1")
  9.         ReDim brr(1 To UBound(arr), 1 To 15) '与效果一不同
  10.         For i = 1 To UBound(arr)
  11.             d(arr(i, 1)) = d(arr(i, 1)) & "," & i
  12.         Next
  13.         dk = d.keys
  14.         di = d.items
  15.         k = 1
  16.         For i = 0 To UBound(dk)
  17.             brr(k, 1) = trr(1, 1)
  18.             brr(k, 2) = trr(1, 2)
  19.             brr(k, 3) = trr(1, 3)
  20.             brr(k, 4) = trr(1, 4)
  21.             brr(k, 5) = trr(1, 5)
  22.             irr = Split(di(i), ",")
  23.             For n = 1 To UBound(irr)
  24.                 x = (n \ 15) * 5 + n Mod 5 + k '结果数组的行号
  25.                 y = ((n Mod 15) \ 5) * 5 '结果数组的列号
  26.                 brr(x, y + 1) = arr(irr(n), 1)
  27.                 brr(x, y + 2) = arr(irr(n), 2)
  28.                 brr(x, y + 3) = arr(irr(n), 3)
  29.                 brr(x, y + 4) = arr(irr(n), 4)
  30.                 brr(x, y + 5) = arr(irr(n), 5)
  31.             Next
  32.             k = 1 - Int(-x / 5) * 5 '下一个仓库名称的起始位置
  33.         Next
  34.         .Range("g1", .Cells(Rows.Count, Columns.Count)).ClearContents
  35.         .Range("i:i").NumberFormat = "@"
  36.         .Range("n:n").NumberFormat = "@"
  37.         .Range("s:s").NumberFormat = "@"
  38.         .Range("g1").Resize(k, 15) = brr
  39.     End With
  40.     Set d = Nothing
  41. End Sub
复制代码

回复

使用道具 举报

wcymiss
 楼主| 发表于 2012-1-12 12:41 | 显示全部楼层
作业三_必做二：
  1. Sub 作业三_必做二()
  2.     Dim d As Object
  3.     Dim arr, dk, brr()
  4.     Dim i As Long, s As String, j As Long
  5.     Set d = CreateObject("scripting.dictionary")
  6.     With Sheets("必二1")
  7.         arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row)
  8.     End With
  9.     For i = 1 To UBound(arr)
  10.         s = arr(i, 1) & "," & arr(i, 2) '日期组合
  11.         If d.exists(arr(i, 5)) Then '父字典的key为产品名称
  12.             d(arr(i, 5))(s) = d(arr(i, 5))(s) + arr(i, 4) '子字典key为日期，item为金额合计
  13.         Else
  14.             Set d(arr(i, 5)) = CreateObject("scripting.dictionary")
  15.             d(arr(i, 5))(s) = d(arr(i, 5))(s) + arr(i, 4)
  16.         End If
  17.     Next
  18.     With Sheets("必二2") '如果要汇总的表多的话可以用循环。
  19.         arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row)
  20.     End With
  21.     For i = 1 To UBound(arr)
  22.         s = arr(i, 1) & "," & arr(i, 2)
  23.         If d.exists(arr(i, 5)) Then
  24.             d(arr(i, 5))(s) = d(arr(i, 5))(s) + arr(i, 4)
  25.         Else
  26.             Set d(arr(i, 5)) = CreateObject("scripting.dictionary")
  27.             d(arr(i, 5))(s) = d(arr(i, 5))(s) + arr(i, 4)
  28.         End If
  29.     Next
  30.     If d.Count > 0 Then '容错,其实我不大喜欢。
  31.         With Sheets("必做二")
  32.             arr = .Range("a2:b" & .Cells(Rows.Count, 1).End(3).Row)
  33.             dk = d.keys
  34.             ReDim brr(1 To UBound(arr) + 1, 1 To UBound(dk) + 1)
  35.             For j = 0 To UBound(dk)
  36.                 brr(1, j + 1) = dk(j) '第一行标题
  37.                 For i = 1 To UBound(arr)
  38.                     s = arr(i, 1) & "," & arr(i, 2)
  39.                     If d(dk(j)).exists(s) Then brr(i + 1, j + 1) = d(dk(j))(s)
  40.                 Next
  41.             Next
  42.             .Range("c1", .Cells(Rows.Count, Columns.Count)).ClearContents
  43.             .Range("c1").Resize(UBound(brr), UBound(brr, 2)) = brr
  44.         End With
  45.     End If
  46.     Set d = Nothing
  47. End Sub
复制代码

回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-4 12:35 , Processed in 0.399534 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表