Vlookup，在vba中一般用Application.Vlookup来实现，但总归要通过循环完成，如有不匹配的还报错，感觉效率不高。这里直接上几个用字典替代vlookup的方法。
方法一(经测试，3000行数据匹配，只需0.0156秒)：
方法一(经测试，3000行数据匹配，只需0.0156秒)：
Sub VLOOKUP_01()
Dim t As Date
t = Timer
Application.ScreenUpdating = False
Sheets("DD").Range("AE2:AF10000").Clear
Set ddcl = Sheets("数据源")
Set dd = Sheets("目标表")
Dim data, temp, arr, brr
Dim d, v
Dim i&, k&
Set d = CreateObject("scripting.dictionary")
Set v = CreateObject("scripting.dictionary")
data = ddcl.[a2].CurrentRegion '被索引的数据表，也可以用具体的区域
'data = ddcl.Range("A1:D65536")
For i = 2 To UBound(data)
d(data(i, 1) & "") = data(i, 3) '被取值所在列，如果只匹配一列，就不需v字典了
v(data(i, 1) & "") = data(i, 4) '被取值所在列
Next
ddm = dd.Range("A65536").End(xlUp).Row
temp = dd.Range("k1:k" & ddm) '索引参照列，注意必须是第一行开始
ReDim arr(2 To UBound(temp), 1 To 1)
ReDim brr(2 To UBound(temp), 1 To 1)
For k = 2 To UBound(temp)
arr(k, 1) = d(temp(k, 1))
brr(k, 1) = v(temp(k, 1))
Next
dd.[AE2].Resize(UBound(arr) - 1, 1) = arr
dd.[AF2].Resize(UBound(brr) - 1, 1) = brr
Set d = Nothing
MsgBox "运行" & Format((Timer - t), "0.0000") & "秒"
End Sub
注意：目标表中的索引参照范围，必须从表的第一行开始，或者用dd.[K1].CurrentRegion
Dim t As Date
t = Timer
Application.ScreenUpdating = False
Sheets("DD").Range("AE2:AF10000").Clear
Set ddcl = Sheets("数据源")
Set dd = Sheets("目标表")
Dim data, temp, arr, brr
Dim d, v
Dim i&, k&
Set d = CreateObject("scripting.dictionary")
Set v = CreateObject("scripting.dictionary")
data = ddcl.[a2].CurrentRegion '被索引的数据表，也可以用具体的区域
'data = ddcl.Range("A1:D65536")
For i = 2 To UBound(data)
d(data(i, 1) & "") = data(i, 3) '被取值所在列，如果只匹配一列，就不需v字典了
v(data(i, 1) & "") = data(i, 4) '被取值所在列
Next
ddm = dd.Range("A65536").End(xlUp).Row
temp = dd.Range("k1:k" & ddm) '索引参照列，注意必须是第一行开始
ReDim arr(2 To UBound(temp), 1 To 1)
ReDim brr(2 To UBound(temp), 1 To 1)
For k = 2 To UBound(temp)
arr(k, 1) = d(temp(k, 1))
brr(k, 1) = v(temp(k, 1))
Next
dd.[AE2].Resize(UBound(arr) - 1, 1) = arr
dd.[AF2].Resize(UBound(brr) - 1, 1) = brr
Set d = Nothing
MsgBox "运行" & Format((Timer - t), "0.0000") & "秒"
End Sub
直接上代码，方便日后查阅：
以上代码会经常使用，可收藏！
Sub byw()
Dim arr, arr1
Dim i%, j%, s%
arr = Sheet6.Range("A1:K" & [A65536].End(3).Row) '第一行为标题行'
ReDim arr1(1 To UBound(arr), 1 To 11)
s = 1
For i = 2 To UBound(arr) '数据区域从第二行开始'
If arr(i, 10) = "是" Then
For j = 1 To 11
'arr1(s, j) = arr(i, j) '如果不改变数组的排列
arr1(s, 1) = s '我给加的一个序号
arr1(s, 2) = arr(i, 5)
arr1(s, 3) = arr(i, 4)
arr1(s, 4) = arr(i, 3)
arr1(s, 5) = arr(i, 1)
arr1(s, 6) = arr(i, 6)
Next
s = s + 1
End If
Next
Sheet1.Range("A4:AU100").ClearContents
Sheet1.[A4].Resize(s, 6) = arr1
End Sub
Dim arr, arr1
Dim i%, j%, s%
arr = Sheet6.Range("A1:K" & [A65536].End(3).Row) '第一行为标题行'
ReDim arr1(1 To UBound(arr), 1 To 11)
s = 1
For i = 2 To UBound(arr) '数据区域从第二行开始'
If arr(i, 10) = "是" Then
For j = 1 To 11
'arr1(s, j) = arr(i, j) '如果不改变数组的排列
arr1(s, 1) = s '我给加的一个序号
arr1(s, 2) = arr(i, 5)
arr1(s, 3) = arr(i, 4)
arr1(s, 4) = arr(i, 3)
arr1(s, 5) = arr(i, 1)
arr1(s, 6) = arr(i, 6)
Next
s = s + 1
End If
Next
Sheet1.Range("A4:AU100").ClearContents
Sheet1.[A4].Resize(s, 6) = arr1
End Sub
以上代码会经常使用，可收藏！
Office2010日历控件
[
2017/07/14 14:51 | by 吕进 | Via 本站原创 ]
2017/07/14 14:51 | by 吕进 | Via 本站原创 ]
Office2010是不自带日历控件的，如何执行通过Office2003或Office2007编写的VB日历控件？
1、下载附件，解压后按说明执行相关操作；
2、进行VBA编辑器，附加日历控件；
3、关闭Excel文件后重新打开即可。
下载文件 (已下载 11755 次)
1、下载附件，解压后按说明执行相关操作；
2、进行VBA编辑器，附加日历控件；
3、关闭Excel文件后重新打开即可。
下载文件 (已下载 11755 次)
在ACCESS中用VBA设置EXCEL单元格的格式
[ 2016/09/25 09:29 | by 吕进 | Via 本站原创 ]
2016/09/25 09:29 | by 吕进 | Via 本站原创 ]
在ACCESS中用VBA更改EXCEL单格元格的格式可用以下代码：
Private Sub test5() 'EXCEL单元格格式设置
Dim excelapplication As Object
Dim str As String
str = Application.CurrentProject.Path & "\book1.xls"
Set excelapplication = GetObject(str) '获取指定的EXCEL文件
With excelapplication.sheets(1)
.Range(.Cells(1, 1), .Cells(3, 4)).Borders.LineStyle = xlContinuous '设置单元格的边框
.Range(.Cells(1, 1), .Cells(3, 4)).Borders.ColorIndex = xlAutomatic '设置单元格边框的颜色，可用1~56间的数字设置不同的颜色
.Range(.Cells(1, 1), .Cells(3, 4)).NumberFormat = "0.00%" '设置单元格的值以百分比的形式显示
.Range(.Cells(1, 1), .Cells(3, 4)).interior.ColorIndex = 24 '设置单元格的颜色
.Range(.Cells(1, 1), .Cells(3, 4)).Font.Bold = True '字体加粗
End With
End Sub
Dim excelapplication As Object
Dim str As String
str = Application.CurrentProject.Path & "\book1.xls"
Set excelapplication = GetObject(str) '获取指定的EXCEL文件
With excelapplication.sheets(1)
.Range(.Cells(1, 1), .Cells(3, 4)).Borders.LineStyle = xlContinuous '设置单元格的边框
.Range(.Cells(1, 1), .Cells(3, 4)).Borders.ColorIndex = xlAutomatic '设置单元格边框的颜色，可用1~56间的数字设置不同的颜色
.Range(.Cells(1, 1), .Cells(3, 4)).NumberFormat = "0.00%" '设置单元格的值以百分比的形式显示
.Range(.Cells(1, 1), .Cells(3, 4)).interior.ColorIndex = 24 '设置单元格的颜色
.Range(.Cells(1, 1), .Cells(3, 4)).Font.Bold = True '字体加粗
End With
End Sub
