|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
背景:
在我实际工作中,在某个Excel 表格中大量使用到Vlookup 函数,相应的副作用也明显,那就造成该文件的计算需求极大的增加,遇到开启文档或者筛选,经常造成电脑卡顿,
解决方向:
参考论坛中的各位之前的代码,使用VBA+自定义菜单,实现Vlookup的功能
各位前辈也请多多指教,看看对代码是否有更好的优化空间
- Private Sub vbalookupPlus()
- Dim lookupRange As Range
- Dim refRange As Range
- Dim dataCol As Integer
- Dim Dict As Object
- Dim myRow As Range
- Dim lookRow As Range
- Dim destinationRow As Range
- On Error Resume Next
- Dim I As Double, J As Double
- ' 1. Build a dictionnary
- Set Dict = CreateObject("Scripting.Dictionary")
- Set lookupRange = Application.InputBox("Pls select lookup range", Type:=8)
- If lookupRange Is Nothing Then
- MsgBox prompt:="You not select any range", Title:="VBALookUp By Fred"
- Exit Sub
- End If
- dataCol = Application.InputBox("CostList's Col", Type:=1)
- If dataCol < 2 Then
- MsgBox prompt:="Lookup Col can't < 2", Title:="VBALookUp By Fred"
- Exit Sub
- End If
- Set destinationRow = Application.InputBox("Paste Ragne", Type:=8)
- If destinationRow Is Nothing Or destinationRow.Cells.Count > 1 Then
- MsgBox prompt:="Error" & Chr(10) & "1.Not Select Range" & Chr(10) & "2.Select Range >2", Title:="VBALookUp By Fred"
- Exit Sub
- End If
- Set refRange = Range("CostList")
- Dim vResults As Variant
- For Each myRow In refRange.Columns(1).Cells
- '2 Append A : B to dictionnary
- If Not Dict.Exists(myRow.Value) Then
- Dict.Add myRow.Value, myRow.Offset(0, dataCol - 1).Value
- End If
- Next myRow
- ReDim vResults(1 To lookupRange.Rows.Count, 1 To 1)
- I = 1
- For Each lookRow In lookupRange
- ' 3. Use it over all lookup data
- If Dict.Exists(lookRow.Value) Then
- vResults(I, 1) = Dict(lookRow.Value)
- Else
- vResults(I, 1) = ""
- End If
- I = I + 1
- Next lookRow
- ' 3. Paste Data on Range
- destinationRow.Resize(UBound(vResults), 1) = vResults
- Set Dict = Nothing
- Set lookupRange = Nothing
- Set destinationRow = Nothing
- Erase vResults
- End Sub
复制代码
|
|