高分求EXCEL下的VBA程序简化、提速、完善。。。
高分求EXCEL下的VBA程序简化、提速、完善。。。 100
Sub a()r = Worksheets("sheet1").Cells(65536, 2).End(xlUp).Rowrr = Worksheets("sheet2").Cells(65536, 1).End(xlUp).RowWorksheets("sheet1").Cells(3, 31) = rWorksheets("sheet1").Cells(3, 32) = rrFor i = 3 To r&&& For j = 3 To rr&&& Worksheets("sheet1").Cells(4, 31) = i&&& Worksheets("sheet1").Cells(4, 32) = j&&& If Worksheets("sheet1").Cells(i, 2) = Worksheets("sheet2").Cells(j, 1) Then&&&&&& Worksheets("sheet2").Cells(j, 32) = "√"&&&&&& Worksheets("sheet1").Cells(i, 33) = Worksheets("sheet2").Cells(j, 5)&&&&&& Worksheets("sheet1").Cells(i, 34) = Worksheets("sheet2").Cells(j, 6)&&&&&& Worksheets("sheet1").Cells(i, 35) = Worksheets("sheet2").Cells(j, 7)&&&&&& Worksheets("sheet1").Cells(i, 36) = Worksheets("sheet2").Cells(j, 8)&&&&&& Worksheets("sheet1").Cells(i, 37) = Worksheets("sheet2").Cells(j, 9)&&&&&& Worksheets("sheet1").Cells(i, 38) = Worksheets("sheet2").Cells(j, 10)&&&&&& Worksheets("sheet1").Cells(i, 39) = Worksheets("sheet2").Cells(j, 11)&&&&&& Worksheets("sheet1").Cells(i, 40) = Worksheets("sheet2").Cells(j, 12)&&&&&& Worksheets("sheet1").Cells(i, 41) = Worksheets("sheet2").Cells(j, 13)&&&&&& Worksheets("sheet1").Cells(i, 42) = Worksheets("sheet2").Cells(j, 14)&&&&&& Worksheets("sheet1").Cells(i, 43) = Worksheets("sheet2").Cells(j, 15)&&&&&& Worksheets("sheet1").Cells(i, 44) = Worksheets("sheet2").Cells(j, 16)&&&&&& Worksheets("sheet1").Cells(i, 45) = Worksheets("sheet2").Cells(j, 17)&&&&&& Worksheets("sheet1").Cells(i, 46) = Worksheets("sheet2").Cells(j, 18)&&&&&& Worksheets("sheet1").Cells(i, 47) = Worksheets("sheet2").Cells(j, 19)&&&&&& Worksheets("sheet1").Cells(i, 48) = Worksheets("sheet2").Cells(j, 20)&&&&&& Worksheets("sheet1").Cells(i, 49) = Worksheets("sheet2").Cells(j, 21)&&&&&& Worksheets("sheet1").Cells(i, 50) = Worksheets("sheet2").Cells(j, 22)&&&&&& Worksheets("sheet1").Cells(i, 51) = Worksheets("sheet2").Cells(j, 23)&&&&&& Worksheets("sheet1").Cells(i, 52) = Worksheets("sheet2").Cells(j, 24)&&&&&& Worksheets("sheet1").Cells(i, 53) = Worksheets("sheet2").Cells(j, 25)&&&&&& Worksheets("sheet1").Cells(i, 54) = Worksheets("sheet2").Cells(j, 26)&&&&&& Worksheets("sheet1").Cells(i, 55) = Worksheets("sheet2").Cells(j, 27)&&&&&& Worksheets("sheet1").Cells(i, 56) = Worksheets("sheet2").Cells(j, 28)&&&&&& Worksheets("sheet1").Cells(i, 57) = Worksheets("sheet2").Cells(j, 29)&&&&&& Worksheets("sheet1").Cells(i, 58) = Worksheets("sheet2").Cells(j, 30)&&&&&& Worksheets("sheet1").Cells(i, 59) = Worksheets("sheet2").Cells(j, 21)&&&&&& Exit For&&& End If&&& Next: NextEnd Sub
这是我写的VBA程序，可以正常执行，但问题是如果要等这个程序完全算完，要十几天的时间，原因是sheet1表里有十万条数据，sheet2表里也有八万条。我用的是IBM的专业服务器，CPU 是Xeon(R) EGHz 双核的CPU，内存4G，硬盘也是一万转的高速硬盘。
所以想请教高手，看有没有什么办法可以把这种合并提快速度。
我自己也想了一下，觉的是不是可以用指针来存储行号，对比完的就可以断开这个行号的链接，这样越到后面所需要比较的行号数量就会越小，速度也就应该越快，可问题是我不知道在VBA下如何用指针，也不知道可不可以这样实现。
还有就是，由于我们单位类似这样的合并每个月都有很多，不知道有没有高手可以帮忙做一个程序，可以直接用这个程序去打个两个EXCEL文档，再指定相应的比对关键字，然后指定所需要合并的几个列，这样就不用每次都要把两个文档放到一个文件的不同表里。如果高手没有时间专门来写这个程序的话，看能不能提供类似于这种程序的网址链接，我可以自己去学着写，谢谢。。。。
如果需要的话，我可以加分，谢谢。。
几分钟完成是没有问题的，给你2个方法：
1、先对sheet1，sheet2分别按b、a列按升序排序
2、分别装入数组，再建立一个临时数组
3、外循环r，里面调用一个递归函数，使用2分法快速定位，如果定位成功进入内循环写入数据
4、结束后数据写入表格
2分法递归10万条数据最多循环20次就可定位（2^20），假设外循环每个数据都能匹配，内循环最多30，所以总的循环数为：10*20*30=6000万个循环，实际不会超过3000万个循环，应该更少。
-------------------------------
使用字典装入sheet2数据，由外循环定位字典中的数据及位置，然后直接进入内循环，由于字典定位速度奇快，所以这时的循环只有10*30=300万个循环，加上定位字典时间，就算它600个循环，所以这个速度完全是可以接受的。
二种方法都需要大量的内存空间，你可以计算一下，代码我就不写了，而且我就2003版的，你那一串我看的都头大，基本是体力话，建议还是用第二种方法。
'---------------------------------
第二种方法当在字典中定位数据后，等处理完内循环的数据后可以使用Remove(key)，这样速度应该更快。你如果把要求写的非常详细，2个表各留10000条数据发给我给你写。条件列的数据必须具有唯一性，不然定位数据就会出错。
300万的空循环用时0.5s，加上它的计算就算效率降低100倍，也就50s，由于使用数组做中间变量，效率应该是非常高的。所以1分钟给你摆平理论上是可行，我不知道字典在海量数据时表现怎么样。
'----------------------------------
'没有数据，自己测试一下，条件是sheet2& a列不能有重复的，由于使用的是字典，键值不能有重复，如果可以速度那是没有问题的，1分钟还是有把握的。未作错误判断假设2个工作表都有数据而且符合我说的条件：
Sub test()&&& Dim i As Long, j As Long, n As Long, t, d As Object, arr, brr&&& t = Timer&&& arr = Sheet1.Range("a3:bg" & Sheet1.[b65536].End(xlUp).Row)&&& brr = Sheet2.Range("a3:af" & Sheet2.[a65536].End(xlUp).Row)&&& Set d = CreateObject("Scripting.Dictionary")&&& For i = 1 To UBound(brr, 1)&&&&&&& d.Add brr(i, 1), i&&& Next&&& For i = 1 To UBound(arr, 1)&&&&&&& If d.exists(arr(i, 2)) Then&&&&&&&&&&& n = d.Item(arr(i, 2))&&&&&&&&&&& brr(n, 32) = "√"&&&&&&&&&&& For j = 33 To 58&&&&&&&&&&&&&&& arr(i, j) = brr(n, j - 28)&&&&&&&&&&& Next&&&&&&&&&&& arr(i, j) = brr(n, 21)&&&&&&& End If&&& Next&&& Sheet1.[a3].Resize(UBound(arr, 1), UBound(arr, 2)) = arr&&& Sheet2.[a3].Resize(UBound(brr, 1), UBound(brr, 2)) = brr&&& Debug.Print Timer - tEnd Sub
首先申明一下，我对VBA只有略懂皮毛，甚至还不如问答了你这个问题的这位高手，但我有些奇怪，EXCEL的有里似乎最多只能支持65535行，楼主说表单里有十万条记录，不知道是否夸张了一点，如果真有这么多记录的话，的确不应该用EXCEL来处理，你可以考虑一下用SQL。
第一步，你在SQL里建一个数据库，每一个字段名对应EXCEL表单里的标题栏就行。
第二步，将EXCEL里的数据完整的导入到这个数据库里。比如数据库A，数据库B。
第三步，你再建一个数据库C，这里的字段包括数据库A和数据库B所有的字段（不重复的）。
第四步，你可以用UPDATE语句和WHERE EXITS语句以及SELECE语句写出一段代码，直接将数据库A和B里的数据根据SELECE里的判断条件复制以数据库C中。同理，你也可以用这几个语句将数据库A和数据库B里需要标记出来的数据做上标志（只不过要在数据库A或B里添加一个标志的字段。）
由于水平有限，代码我就不放上来丢人现眼了，如果楼主有兴趣的话，可以留下你的信箱或QQ号，我们单聊。
我的信箱是
请高手指点，谢谢。。
其他回答 (1)
我没验证，你试试吧。Sub a()Dim r, rr As Integer& '申明变量，好习惯，且有助于加快速度Application.ScreenUpdating = False& '关闭屏幕刷新，速度Application.Calculation = xlCalculationManual&& '关闭自动计算，速度r = Worksheets("sheet1").Cells(65536, 2).End(xlUp).Rowrr = Worksheets("sheet2").Cells(65536, 1).End(xlUp).RowSheets("Sheet1").SelectCells(3, 31) = rCells(3, 32) = rr&&& 'Worksheets("sheet1").Cells(4, 31) = i& 原来循环里的这两句貌似没用，去掉了。如果有用，比较麻烦&&& 'Worksheets("sheet1").Cells(4, 32) = jCells(3, 33) = "=if(iserror(vlookup($B3,Sheet2!$A$3:$U$" & rr & ",column(e1),0)),"""",vlookup($B3,Sheet2!$A$3:$U$" & rr & ",column(e1),0))"'上述代码在单元格AG3写了一公式 =IF(ISERROR(VLOOKUP($B3,Sheet2!$A$3:$U$rr,COLUMN(E1),0)),"",VLOOKUP($B3,Sheet2!$A$3:$U$rr,COLUMN(E1),0))Cells(3, 33).Copy&& '复制到AG3:BGrRange("AG3:BG" & r).SelectActiveSheet.PasteSelection.Copy&&&&& '粘贴为数值Selection.PasteSpecial Paste:=xlPasteValuesSheets("Sheet2").SelectCells(3, 32) = "=if(countif(Sheet1!B$3:B$" & r & ", A3),""√"","""")"&& '在AF3写一判断公式Cells(3, 32).AutoFill Destination:=Range("AF3:AF" & rr) '填充下去Range("AF3:AF" & rr).Copy&& '粘贴为数值Range("AF3:AF" & rr).PasteSpecial xlPasteValues&&& Application.CutCopyMode = False '清空剪切板Application.ScreenUpdating = True&& '恢复屏幕刷新Application.Calculation = xlCalculationAutomatic&&& '恢复自动计算End Sub
首先要感谢高手抽空帮忙回答。
我将程序完整的复制过去，执行时弹出一个提示：“运行时错误：'1004'，类Range的AutoFill方法无效”然后就是结束和调戏两个按钮可用。。
请问一下是不是我系统版本的原因，我用的是XP+OFFICE 2010
高手，我选择调戏，Cells(3, 32).AutoFill Destination:=Range("AF3:AF" & rr) '填充下去这一条高亮，是不是问题出在这一条上。
还有一个问题想要请教，我写的代码里
Worksheets("sheet1").Cells(4, 31) = i&&& Worksheets("sheet1").Cells(4, 32) = j这两条的目地是在单元格里显示现在已执行到了哪一条，对我来说就相当于一个简易的进度条，可以让我知道已经搞到什么进度了，可高手你的程序里似乎没办法让我知道进度，不知道有没有什么办法可以在提高速度的同时还看到运行进度呢？谢谢。
把Cells(3, 32).AutoFill Destination:=Range("AF3:AF" & rr) '填充下去Range("AF3:AF" & rr).Copy&& '粘贴为数值Range("AF3:AF" & rr).PasteSpecial xlPasteValues改为Range("AF3:AF" & rr).SelectActiveSheet.PasteSelection.Copy&&&&& '粘贴为数值Selection.PasteSpecial Paste:=xlPasteValues应该就可以了。你用了循环，有进度一说，我直接用的是公式，不存在进度。理论上，速度会比你原理快很多很多。如果在Sheet2打对勾也是看进度的话，那么Sheets("Sheet2").SelectCells(3, 32) = "=if(countif(Sheet1!B$3:B$" & r & ", A3),""√"","""")"&& '在AF3写一判断公式Range("AF3:AF" & rr).Select
ActiveSheet.Paste
Selection.Copy&&&&& '粘贴为数值
Selection.PasteSpecial Paste:=xlPasteValues可以都删除了，没意义。
打对勾不是看进度的，是做标志，看出哪些数据已参与了比对，没有打勾的就是有问题的数据，是需要处理的。。。
高手，那你有没有办法可以在程序里显示出进度来呢？因为程序工作时，领导随时要问进度的。。
我都和你说了，这个方法没有进度，理论上前面都不花时间，直到最后的Application.Calculation = xlCalculationAutomatic&&& '恢复自动计算才会花时间计算（如果你数据量大的话，确实要花一些时间）。最后两句应该调换位置，即先计算，再刷新屏幕。还有，你这么大的数据量，不应该用Excel了，会死机的。考虑用Access之类的数据库技术，我年轻时候会用，这10多年不用，现在也不会了。
大哥，你的程序还是不对啊，他只用了几秒就结束了，但所需要的值还是没有赋过来。。
说实话，我也没验证，只是告诉你思路。又帮你改了一下，自己调试吧。关键是思路。Sub a()Dim r, rr As Integer& '?ê?÷±????????°?ss???????ú?? 1/4 ??ì????Application.ScreenUpdating = False& '??±?AE??>>??????????Application.Calculation = xlCalculationManual&& '??±?×??? 1/4 AE????????r = Worksheets("sheet1").Cells(65536, 2).End(xlUp).Rowrr = Worksheets("sheet2").Cells(65536, 1).End(xlUp).RowSheets("Sheet1").SelectCells(3, 31) = rCells(3, 32) = rr&&& 'Worksheets("sheet1").Cells(4, 31) = i& ?-???->>·??u???? 1/2
3/4 ????AE?>>??????u???????????????±? 1/2 ??é·?&&& 'Worksheets("sheet1").Cells(4, 32) = jCells(3, 33) = "=if(iserror(vlookup($B3,Sheet2!$A$3:$U$" & rr & ",column(e1),0)),"""",vlookup($B3,Sheet2!$A$3:$U$" & rr & ",column(e1),0))"'?????ú????u???,?AG3?????>>?<<? 1/2
=IF(ISERROR(VLOOKUP($B3,Sheet2!$A$3:$U$rr,COLUMN(E1),0)),"",VLOOKUP($B3,Sheet2!$A$3:$U$rr,COLUMN(E1),0))Cells(3, 33).Copy&& ',??AEu 1/2 AG3:BGrRange("AG3:BG" & r).SelectActiveSheet.PasteApplication.Calculation = xlCalculationAutomatic&&& '>>?,?×??? 1/4 AE??Selection.Copy&&&&& '???ù?????uSelection.PasteSpecial Paste:=xlPasteValuesApplication.Calculation = xlCalculationManual&& '??±?×??? 1/4 AE????????Sheets("Sheet2").SelectCells(3, 32) = "=if(countif(Sheet1!B$3:B$" & r & ", A3),""??"","""")"&& '??AF3???>>?????<<? 1/2 Cells(3, 32).CopyRange("AF3:AF" & rr).SelectActiveSheet.PasteApplication.Calculation = xlCalculationAutomatic&&& '>>?,?×??? 1/4 AE??Selection.Copy&&&&& '???ù?????uSelection.PasteSpecial Paste:=xlPasteValues&& Application.CutCopyMode = False '???? 1/4 ???°?Application.ScreenUpdating = True&& '>>?,?AE??>>????End Sub
相关知识等待您来回答
微软专区领域专家12:01:27|&&分类：
|&&标签： |字号大中小&订阅
录制宏的局限性
1，录制的宏没有判断能力，也没有循环能力，一次缺乏灵活性。
2，不具有人机交互能力，即用户无法进行输入，在宏运行中计算机也无法给出必要的提示。
3，无法显示xls的对话框
4，无法显示和使用用户窗体
VBA:Visual Basic For Application,面向对象的编程语言
对象 属性 方法&
工程窗口，代码窗口，属性窗口，立即窗口
对象列表框 & 过程列表框
视图：过程视图，全模块视图
VBA模块的导入与导出（后缀.bas）
帮助像一个无时不在的老师
数值型变量分为：整型，长整型，字节型，单精度型，双精度型
VBA自定义类型【另一篇转来的日志】
在VBA系统内部的符号常量是用VB前缀标志的，而Excel系统的常量是用xl前缀标志的
在VBA中，用户使用Const语句定义常量，这类常量必须先声明才能使用，Const语句的语法格式如下：
[Public|Private] Const 常量名 [As 数据类型]=表达式
功能：将表达式表示的数据值赋值给指定的符号常量，默认为私有的
VBA数组运用
一、数组的分类&
按元素数目分：元素数目大小固定的数组和元素数目大小不固定的动态数组。&
按维数分：一维数组、多维数组。&
Arr(1 to 12)、Arr1(0 to 24)----一维固定数组；&
Arr2(1 to 5,1 to 8)---- 二维固定数组；&
Arr3(5 to 10,6 to 12,1 to 100) ----
三维固定数组。&
Dim Arr2(),r%&
ReDim Preserve Arr2(1 To r)
&#8213;&#8213;&#8213;动态数组；可以重新声明（只有最后一维的数目才能重新声明）；&
用了关键字 & Preserve &
可确保原来包含数据的数组中的任何数据都不会丢失&
====================================================&
====================================================&
二、数组的赋值&
2.1，单元格区域保存到数组&
arr = [e22:i24]&
arr=Range(“e22:i24”)&
2.2，Array函数&
myArray = Array("AAA", "BBB", 200, 500,
如果代码头没有 Option Base 1
的语句，则数组myArray的上限为4，下限为0。&
即下限LBound(myArr)=0 ，上限 UBound(myArr)=4&
二维数组的第一维的上限：UBound(Arr,1)&
二维数组的第二维的上限：UBound(Arr,2)&
多维数组上限的求法一样。&
2.3，把单元格区域公式赋给数组&
如果a5=B4+1&
arr = [a4:c8].Formula '将单元格绝对引用公式保存到数组&
[e4:g8]=arr 此时e5中的公式也＝B4+1;&
如果将单元格相对引用公式保存到数组&
arr = [a4:c8].FormulaR1C1&
如果a5=B4+1&
[e4:g8]=arr 此时e5中的公式就＝E4+1;&
====================================================&
====================================================&
三、数组的处理&
3.1，数组里的最大值和最小值&
最大值aa =
Application.WorksheetFunction.Max(Arr)&
Application.WorksheetFunction.Large(Arr,1)&
最小值aa =
Application.WorksheetFunction.Min(Arr)&
Application.WorksheetFunction.Small(Arr,1)&
3.2，数组里搜索&
Temp = Filter(Arr, xm(i)) '搜索数组&
Dim Arr(), aa$, x%&
aa = "asssfffssssaaasss": bb = "s"&
For x = 1 To Len(aa)&
& &ReDim Preserve Arr(1 To
& &Arr(x) = Mid(aa, x,
temp = Filter(Arr, bb)&
cc = UBound(temp) + 1 &
‘cc=”s”的个数&
用于对字符串数组进行搜索，得到一个新的数组temp，&
缺点：只告诉你某元素是否存在于数组中，而不知道其具体位置；&
数组精确搜索：&
Sub FilterExactMatch()&
' 该函数在一个字符串数组中搜索那些&
' 与搜索字符串完全匹配的元素。&
Dim astrFilter() As String&
Dim astrTemp() As String&
Dim lngUpper As Long&
Dim lngLower As Long&
Dim lngIndex As Long&
Dim lngCount As Long&
astrItems = Array("a", "sas", "s", "Sas", "s", "f", "f", "f",
"f", "sas", "s", "sas", "a", "a", "Sas", "s",
strSearch = "Sas"&
' 为搜索字符串而过滤数组。&
astrFilter = Filter(astrItems,
strSearch)&
' 存储结果数组的上限和下限。&
lngUpper = UBound(astrFilter)&
lngLower = LBound(astrFilter)&
' 将临时数组调整到相同大小。&
ReDim astrTemp(lngLower To lngUpper)&
' 在经过滤的数组的每个元素中循环。&
For lngIndex = lngLower To lngUpper&
检查该元素是否与搜索字符串完全匹配。&
& &If astrFilter(lngIndex) =
strSearch Then&
' 在另一个数组中存储完全匹配的元素。&
astrTemp(lngCount) = strSearch&
lngCount = lngCount + 1&
Next lngIndex&
' 重新调整包含完全匹配的元素的数组的大小。&
ReDim Preserve astrTemp(lngLower To lngCount -
' 返回包含完全匹配的元素的数组。&
[a5].Resize(1, UBound(astrTemp) + 1) =
Application.Transpose(astrTemp)&
3.3，转置&
取工作表区域的转置到数组：arr=Application.Transpose([a1:c5])
& ‘此时arr是转置成3行5列的数组，arr(1 to 3,1 to
[e1:i3]=arr ‘此时3行5列。&
数组间也可以转置：arr1=Application.Transpose(arr)&
取数组arr的第n列赋值到某列区域：[e1:e5]=Application.Index(arr, 0,
也可写成 [e1:e5]=Application.Index(arr, ,
赋值产生一个新数组：arr1=Application.Index(arr,0 ,
取数组arr的第n行赋值到某行区域：[a6:c6]=Application.Index(arr,n ,0
也可写成 [a6:c6]=Application.Index(arr,n )
省略0，也省略了“，“&
赋值产生一个新数组：arr1=Application.Index(arr, n
3.4，数组的比较（字典法）&
题目：将A列中的数据与C列相比较,输出C列中没有的数据到D列：&
‘by:ccwan&
& &Dim arr, brr, i&,
x&, d As Object&
& &arr = Range("a1:a" &
[a65536].End(xlUp).Row)&
& &brr = Range("c1:c" &
[c65536].End(xlUp).Row)&
& &Set d =
CreateObject("scripting.dictionary")&
& &For i = 1 To
UBound(arr)&
& &d(arr(i, 1)) =
& &For x = 1 To
UBound(brr)&
& &If d.exists(brr(x, 1))
& &d.Remove brr(x,
& &[d1].Resize(d.Count, 1) =
Application.Transpose(d.keys)&
3.5，数组的排序&
字符串数组不能用Large(Arr,i) 或者 Small(Arr,i)
但数值数组可以；&
一个很好的字典+数组排序的实例：&
Sub yy1()&
‘by:oobird&
Dim i%, c As Range, x, d As Object&
CreateObject("Scripting.Dictionary")&
For Each c In Sheet2.UsedRange&
& &If c.Value && ""
& &If Not d.exists(c.Value)
& &d.Add c.Value,
& &d(c.Value) = d(c.Value) +
& &k = d.keys: t = d.items
& 'k是各个不重复值，t是各个不重复值的个数&
& &ReDim x(1 To 2, 1 To
For i = 1 To d.Count&
& &x(2, i) =
Application.Large(k, i) ‘从大到小排序&
& &x(1, i) = d(x(2,
With Sheet1&
& &.[b2].Resize(2, i - 1) =
& &ReDim x(1 To 2, 1 To
& &For i = 1 To
& &x(1, i) =
Application.Max(t) ‘从大到小排序&
Application.Match(x(1, i), t, 0) & 1 &
‘查找此值在不重复值系列中的排位，因为w是从0开始的，所以－1&
& &x(2, i) = k(w)
& ‘求得对应的不重复值&
& &t(w) = ""
‘使前面的最大值为空，继续循环&
&VBA调用工作表函数
application.worksheetfunction.函数名（参数）
在工作表单元格插入工作表函数
worksheets("sheet1").range("A1:A3").formula="=rand()"
四类函数：
算术函数 字符串函数 &转化函数
&日期时间函数
使用Stop语句
VBA 错误的处理
on error goto&
Msgbox 中的回车符 Chr(13) &换行符 Ch(10)
多条件语句
///////////////select case
select case
///////////////////////////////////////
iff(判断式，结果，结果)
//////////循环结构
for 循环变量=初值 To 终值 [step 步长]
next 循环变量
for each 元素 in 集合
Do [{While|until}&条件&]
loop [{While|until}&条件&]
命名参数的作用。
在对象方法中，不能使用符号常量的表示方法，这就给理解和使用参数带了了难度。为此VBA采用一种称为命名参数的方法，来明确表示具体参数，即“参数名称：=参数”
在程序中，除第一个命名参数可以省略外，其他的命名参数都不能省略。
对象是EXcel VBA 中基本的运行实体，工作薄，工作表，单元格，图表，用户窗体，窗体上的控件，等都是对象。
对象具有属性，方法和事件三个要素。
属性包括：名称，大小位置，显示状态等属性
声明一般的对象，如果事先不知道所指定的对象变量类型，只有等到过程运行才知道指定的对象类型时，可以利用Object数据类型来声明，使用Object数据类型来创建对任何对象的一般引用，如：
Dim myObject AS object
set myobject=yourobject
声明对象的时候同时赋值
可以使用new关键字和set语句来声明对象变量，并给它赋值一个对象：
Set myobject =new yourobject
中断变量关联
在一个过程结束后，应该中断变量与对象的关联，这样就可以释放在内存中所占的空间。
中断变量关联的语句形式：Set myobject=nothing
已投稿到：
以上网友发言只代表其个人观点，不代表新浪网的观点或立场。&#xe602; 下载
&#xe60c; 收藏
该文档贡献者很忙，什么也没留下。
&#xe602; 下载此文档
正在努力加载中...
VBA字典用法集锦及代码详解
下载积分：20
内容提示：
文档格式：DOC|
浏览次数：2|
上传日期： 13:23:24|
文档星级：&#xe60b;&#xe612;&#xe612;&#xe612;&#xe612;
该用户还上传了这些文档
VBA字典用法集锦及代码详解.DOC
官方公共微信查看: 649|回复: 7|
在线时间2 小时经验59 威望0 性别男最后登录注册时间阅读权限20UID629390积分59帖子精华0分享0
EH初级, 积分 59, 距离下一级还需 291 积分
积分排行3000+帖子精华0微积分0
(8.92 KB, 下载次数: 9)
10:56 上传
下载次数: 9
请个位大侠们帮忙下载附件看看，谢谢
在线时间3523 小时经验10776 威望6 性别男最后登录注册时间阅读权限95UID188110积分10876帖子精华0分享0
积分排行65帖子精华0微积分0
Sub test()
&&Dim d As New Dictionary
&&Dim r%, i%
&&Dim arr, brr()
&&With Worksheets(&流水账&)
& & r = .Cells(.Rows.Count, 1).End(xlUp).Row
& & arr = .Range(&a2:h& & r)
& & For i = 1 To UBound(arr)
& && &xm = arr(i, 8) & &+& & Format(arr(i, 7), &yyyy-m-d hh:mm&)
& && &If Not d.Exists(xm) Then
& && &&&m = 1
& && &Else
& && &&&m = UBound(d(xm), 2) + 1
& && &End If
& && &ReDim Preserve brr(1 To 8, 1 To m)
& && &For j = 1 To 8
& && &&&brr(j, m) = arr(i, j)
& && &Next
& && &d(xm) = brr
& & Next
&&End With
& &
&&With Worksheets(&单据打印&)
& & xm = .Range(&b3&) & &+& & Format(.Range(&i3&), &yyyy-m-d hh:mm&)
& & m = 5
& & If d.Exists(xm) Then
& && &brr = Application.Transpose(d(xm))
& && &For i = 1 To UBound(brr)
& && &&&m = m + 1
& && &&&.Cells(m, 2) = brr(i, 1)
& && &&&.Cells(m, 3) = brr(i, 2)
& && &&&.Cells(m, 6) = brr(i, 6)
& && &&&.Cells(m, 7) = IIf(.Range(&d1&) = &入库单&, brr(i, 4), brr(i, 5))
& && &Next
& & End If
&&End With
& && &&&
& &
End Sub复制代码
在线时间3523 小时经验10776 威望6 性别男最后登录注册时间阅读权限95UID188110积分10876帖子精华0分享0
积分排行65帖子精华0微积分0
没弄明白楼主的时间相等是等到什么精度，是等到“天”，还是等到“时”或“分”或“秒”？本程序是相等到“分”。
11:46 上传
下载次数: 16
13.32 KB, 下载次数: 16
在线时间6113 小时经验30816 威望12 最后登录注册时间阅读权限100UID646032积分31566帖子精华2分享0
管理以下版块
积分排行6帖子精华2微积分0
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = &$D$1& Then
& & [i3] = &&
& & If Target && &入库单& Then [b3] = &&
ElseIf Target.Address = &$I$3& Then
& & Dim Arr, i&, rq, th$, n&, kh$
& & [b6:j15].ClearContents
& & rq = Target.Value: n = 5
& & th = [d1].Value: kh = [b3].Value
& & If th = && Then Exit Sub
& & If th = &入库单& Then rk = 1 Else rk = 0
& & Arr = Sheet1.[a1].CurrentRegion
& & For i = 2 To UBound(Arr)
& && &&&If CDate(Split(Arr(i, 7))(0)) = rq Then
& && && && &If rk = 1 Then
& && && && && & If kh && && Then
& && && && && && &&&If Arr(i, 4) && && Then
& && && && && && && && &If Arr(i, 8) = kh Then
& && && && && && && && && & n = n + 1
& && && && && && && && && & Cells(n, 2) = Arr(i, 1)
& && && && && && && && && & Cells(n, 3) = Arr(i, 2)
& && && && && && && && && & Cells(n, 6) = Arr(i, 6)
& && && && && && && && && & Cells(n, 7) = Arr(i, 4)
& && && && && && && && &End If
& && && && && && &&&End If
& && && && && & Else
& && && && && && &&&MsgBox &请选择客户名称。&
& && && && && & End If
& && && && &Else
& && && && && & If Arr(i, 5) && && Then
& && && && && & n = n + 1
& && && && && & Cells(n, 2) = Arr(i, 1)
& && && && && & Cells(n, 3) = Arr(i, 2)
& && && && && & Cells(n, 6) = Arr(i, 6)
& && && && && & Cells(n, 7) = Arr(i, 5)
& && && && && & End If
& && && && &End If
& && &&&End If
& & Next
Else
& & Exit Sub
End If
End Sub复制代码
在线时间6113 小时经验30816 威望12 最后登录注册时间阅读权限100UID646032积分31566帖子精华2分享0
管理以下版块
积分排行6帖子精华2微积分0
请见附件。
14:57 上传
下载次数: 24
12.33 KB, 下载次数: 24
在线时间2 小时经验59 威望0 性别男最后登录注册时间阅读权限20UID629390积分59帖子精华0分享0
EH初级, 积分 59, 距离下一级还需 291 积分
积分排行3000+帖子精华0微积分0
日期只要等于“天”就行
在线时间2 小时经验59 威望0 性别男最后登录注册时间阅读权限20UID629390积分59帖子精华0分享0
EH初级, 积分 59, 距离下一级还需 291 积分
积分排行3000+帖子精华0微积分0
这几位大侠们不愧是excel界精英，水平真的很厉害，没想到这么快就有成果出来，小弟我也想学习一下。
在线时间2 小时经验59 威望0 性别男最后登录注册时间阅读权限20UID629390积分59帖子精华0分享0
EH初级, 积分 59, 距离下一级还需 291 积分
积分排行3000+帖子精华0微积分0
蓝桥玄霜 发表于
请见附件。
还有个问题需要您帮忙一下的，就是说如果那个流水账中的数据满足条件的条目过多那就会导致单据表中现有的格子装不下，看看能否保证在单据表中一次只显示10或15条，其它多余的通过打印预览来显示。“表中增加一个打印预览和打印的按钮”
积分≥4700即可申请
最佳会员奖章No.1
金牌优秀会员
金牌优秀会员奖章No.1
优秀会员奖章No.2
优秀会员奖章No.1
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&}