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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 一个不知道怎么表达的vba问题
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1817|回复: 5

[已解决]一个不知道怎么表达的vba问题

[复制链接]
发表于 2015-6-12 08:21 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
希望老师能帮忙给解决下
最佳答案
月排行榜 / 总排行榜
白开水的微笑
2015-6-12 13:13
  1. Sub MyList()
  2.     Dim d1  As Object   'Dic of D-->E 1:N   Sheet2
  3.     Dim d2  As Object   'Dic of E-->F 1:N   Sheet2
  4.     Dim d3  As Object   'Dic of F-->G 1:N   Sheet1
  5.     Dim d4  As Object   'Dic of Date  1:N   Sheet1
  6.     Dim arr1            'Sheet1
  7.     Dim arr2            'Sheet2
  8.     Dim arrResult       'Sheet4
  9.     Dim rowN    As Long
  10.     Dim rowNR   As Long
  11.     Dim arrTmp
  12.     Dim tempS
  13.     Dim Temp
  14.     Dim tempResult
  15.    
  16.     Set d1 = CreateObject("Scripting.Dictionary")
  17.     Set d2 = CreateObject("Scripting.Dictionary")
  18.     Set d3 = CreateObject("Scripting.Dictionary")
  19.     Set d4 = CreateObject("Scripting.Dictionary")
  20.     'Create Dic3
  21.     arr1 = Sheet1.Range("A1").CurrentRegion.Value
  22.     For rowN = 1 To UBound(arr1)
  23.         d3(arr1(rowN, 4)) = arr1(rowN, 5)
  24.         Temp = arr1(rowN, 1) & "-" & arr1(rowN, 2) & "-" & arr1(rowN, 3)
  25.         If d4.exists(Temp) Then
  26.             d4(Temp) = d4(Temp) & vbLf & arr1(rowN, 4)
  27.         Else
  28.             d4(Temp) = arr1(rowN, 4)
  29.         End If
  30.                
  31.     Next rowN
  32.    
  33.     'Create Dic1,Dic2
  34.     arr2 = Sheet2.Range("A1").CurrentRegion.Value
  35.     For rowN = 1 To UBound(arr2)
  36.         If d1.exists(arr2(rowN, 1)) Then
  37.             d1(arr2(rowN, 1)) = d1(arr2(rowN, 1)) & vbLf & arr2(rowN, 2)
  38.         Else
  39.             d1(arr2(rowN, 1)) = arr2(rowN, 2)
  40.         End If
  41.         If d2.exists(arr2(rowN, 2)) Then
  42.             d2(arr2(rowN, 2)) = d2(arr2(rowN, 2)) & vbLf & arr2(rowN, 1)
  43.         Else
  44.             d2(arr2(rowN, 2)) = arr2(rowN, 1)
  45.         End If
  46.     Next rowN
  47.    
  48.     With Sheet4
  49.         .Range("D:G").ClearContents
  50.         arrResult = .Range("A1:G" & .Range("A1").CurrentRegion.Rows.Count).Value
  51.         For rowN = 1 To UBound(arrResult)
  52.             Temp = d4(arrResult(rowN, 1) & "-" & arrResult(rowN, 2) & "-" & arrResult(rowN, 3))
  53.             If Temp <> "" Then
  54.                 arrResult(rowN, 4) = Temp
  55.                 'Get E Column
  56.                 tempResult = ""
  57.                 For Each tempS In Split(Temp, vbLf)
  58.                     If d1.exists(tempS) Then
  59.                         tempResult = tempResult & vbLf & d1(tempS)
  60.                     End If
  61.                 Next tempS
  62.                 If tempResult <> "" Then _
  63.                     arrResult(rowN, 5) = Right(tempResult, Len(tempResult) - 1)
  64.                 'Get F Column
  65.                 Temp = tempResult
  66.                 tempResult = ""
  67.                 For Each tempS In Split(Temp, vbLf)
  68.                     If d2.exists(tempS) Then
  69.                         tempResult = tempResult & vbLf & d2(tempS)
  70.                     End If
  71.                 Next tempS
  72.                 If tempResult <> "" Then _
  73.                     arrResult(rowN, 6) = Right(tempResult, Len(tempResult) - 1)
  74.                 'Get G Column
  75.                 Temp = tempResult
  76.                 tempResult = ""
  77.                 For Each tempS In Split(Temp, vbLf)
  78.                     If d3.exists(tempS) Then
  79.                         tempResult = tempResult & vbLf & d3(tempS)
  80.                     End If
  81.                 Next tempS
  82.                 If tempResult <> "" Then _
  83.                     arrResult(rowN, 7) = Right(tempResult, Len(tempResult) - 1)
  84.             End If
  85.             
  86.         Next rowN
  87.         
  88.         .Range("A1").Resize(UBound(arrResult), 7).Value = arrResult
  89.     End With
  90. End Sub
复制代码
00001.jpg

00001.rar

19.73 KB, 下载次数: 15
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2015-6-12 12:30 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
大师们，版主们救命。。。。。。。。。。。。。
回复

使用道具 举报

发表于 2015-6-12 13:13 | 显示全部楼层    本楼为最佳答案   
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub MyList()
  2.     Dim d1  As Object   'Dic of D-->E 1:N   Sheet2
  3.     Dim d2  As Object   'Dic of E-->F 1:N   Sheet2
  4.     Dim d3  As Object   'Dic of F-->G 1:N   Sheet1
  5.     Dim d4  As Object   'Dic of Date  1:N   Sheet1
  6.     Dim arr1            'Sheet1
  7.     Dim arr2            'Sheet2
  8.     Dim arrResult       'Sheet4
  9.     Dim rowN    As Long
  10.     Dim rowNR   As Long
  11.     Dim arrTmp
  12.     Dim tempS
  13.     Dim Temp
  14.     Dim tempResult
  15.    
  16.     Set d1 = CreateObject("Scripting.Dictionary")
  17.     Set d2 = CreateObject("Scripting.Dictionary")
  18.     Set d3 = CreateObject("Scripting.Dictionary")
  19.     Set d4 = CreateObject("Scripting.Dictionary")
  20.     'Create Dic3
  21.     arr1 = Sheet1.Range("A1").CurrentRegion.Value
  22.     For rowN = 1 To UBound(arr1)
  23.         d3(arr1(rowN, 4)) = arr1(rowN, 5)
  24.         Temp = arr1(rowN, 1) & "-" & arr1(rowN, 2) & "-" & arr1(rowN, 3)
  25.         If d4.exists(Temp) Then
  26.             d4(Temp) = d4(Temp) & vbLf & arr1(rowN, 4)
  27.         Else
  28.             d4(Temp) = arr1(rowN, 4)
  29.         End If
  30.                
  31.     Next rowN
  32.    
  33.     'Create Dic1,Dic2
  34.     arr2 = Sheet2.Range("A1").CurrentRegion.Value
  35.     For rowN = 1 To UBound(arr2)
  36.         If d1.exists(arr2(rowN, 1)) Then
  37.             d1(arr2(rowN, 1)) = d1(arr2(rowN, 1)) & vbLf & arr2(rowN, 2)
  38.         Else
  39.             d1(arr2(rowN, 1)) = arr2(rowN, 2)
  40.         End If
  41.         If d2.exists(arr2(rowN, 2)) Then
  42.             d2(arr2(rowN, 2)) = d2(arr2(rowN, 2)) & vbLf & arr2(rowN, 1)
  43.         Else
  44.             d2(arr2(rowN, 2)) = arr2(rowN, 1)
  45.         End If
  46.     Next rowN
  47.    
  48.     With Sheet4
  49.         .Range("D:G").ClearContents
  50.         arrResult = .Range("A1:G" & .Range("A1").CurrentRegion.Rows.Count).Value
  51.         For rowN = 1 To UBound(arrResult)
  52.             Temp = d4(arrResult(rowN, 1) & "-" & arrResult(rowN, 2) & "-" & arrResult(rowN, 3))
  53.             If Temp <> "" Then
  54.                 arrResult(rowN, 4) = Temp
  55.                 'Get E Column
  56.                 tempResult = ""
  57.                 For Each tempS In Split(Temp, vbLf)
  58.                     If d1.exists(tempS) Then
  59.                         tempResult = tempResult & vbLf & d1(tempS)
  60.                     End If
  61.                 Next tempS
  62.                 If tempResult <> "" Then _
  63.                     arrResult(rowN, 5) = Right(tempResult, Len(tempResult) - 1)
  64.                 'Get F Column
  65.                 Temp = tempResult
  66.                 tempResult = ""
  67.                 For Each tempS In Split(Temp, vbLf)
  68.                     If d2.exists(tempS) Then
  69.                         tempResult = tempResult & vbLf & d2(tempS)
  70.                     End If
  71.                 Next tempS
  72.                 If tempResult <> "" Then _
  73.                     arrResult(rowN, 6) = Right(tempResult, Len(tempResult) - 1)
  74.                 'Get G Column
  75.                 Temp = tempResult
  76.                 tempResult = ""
  77.                 For Each tempS In Split(Temp, vbLf)
  78.                     If d3.exists(tempS) Then
  79.                         tempResult = tempResult & vbLf & d3(tempS)
  80.                     End If
  81.                 Next tempS
  82.                 If tempResult <> "" Then _
  83.                     arrResult(rowN, 7) = Right(tempResult, Len(tempResult) - 1)
  84.             End If
  85.             
  86.         Next rowN
  87.         
  88.         .Range("A1").Resize(UBound(arrResult), 7).Value = arrResult
  89.     End With
  90. End Sub
复制代码

评分

参与人数 1 +20 金币 +20 收起 理由
qh8600 + 20 + 20 师傅太牛了

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-6-12 13:31 | 显示全部楼层
白开水的微笑 发表于 2015-6-12 13:13

谢谢老师，我先学习学习，不懂再请教，非常谢谢
回复

使用道具 举报

 楼主| 发表于 2015-6-12 13:40 | 显示全部楼层
白开水的微笑 发表于 2015-6-12 13:13

再次感谢老师，得到了想要的结果
QQ截图20150612133621.jpg
回复

使用道具 举报

发表于 2015-6-12 14:24 | 显示全部楼层
没看懂
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-5-15 16:55 , Processed in 0.254163 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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