[已解决]求帮编写个简单的VBA

13958206051

第二个sheet是数据源，第一个sheet是要查找的数据，我现在做的表是根据输入的产品编号用VLOOKUP的方法把数据源的数据匹配过来，正常没问题，可是正常都是要匹配十几万的数据，电脑会非常卡，求大神编写个VBA，怎么方便怎么来。达到相同的效果就行了，谢谢！在线等！！！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-10-12 10:14

用数组批量查找。

1. Sub 查找()
   
2.     Application.ScreenUpdating = False
   
3.     Dim i As Integer
   
4.     arr = Sheets("全部产品").[a1].CurrentRegion
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     brr = Range("a1:f" & Cells(Rows.Count, 1).End(3).Row)
   
7.     For i = 2 To UBound(arr)
   
8.         d(arr(i, 1)) = i
   
9.     Next
   
10.     For i = 2 To UBound(brr)
    
11.         k = d(brr(i, 1))
    
12.         If k > 0 Then
    
13.             For j = 2 To UBound(brr, 2)
    
14.                 brr(i, j) = arr(k, j)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     Range("a1:f" & Cells(Rows.Count, 1).End(3).Row) = brr
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码

跳转到最佳答案楼层

baksy

把vlookup函数的第二参数限定区限，可以提高一些速度。
=IFERROR(VLOOKUP($A2,全部产品!$A$1:$F$5999,COLUMN(B$1),0),"")

13958206051

baksy 发表于 2015-10-11 10:28
把vlookup函数的第二参数限定区限，可以提高一些速度。
=IFERROR(VLOOKUP($A2,全部产品!$A$1:$F$5999,COLU ...

数据源区的数据我已经删掉很多了，基本也有十几万的数据的，，我上传特意删掉很多了。

江河行地

Sub 查找()
Application.ScreenUpdating = False
    Dim i As Integer
    For i = 2 To Range("a1048536").End(xlUp).Row
        x = Sheets("全部产品").Cells.Find(Range("a" & i)).Row
        Sheets("全部产品").Range("B" & x & ":F" & x).Copy Sheets("查供应价").Range("B" & i & ":F" & i)
    Next
Application.ScreenUpdating = True
End Sub

也很慢。

13958206051

江河行地 发表于 2015-10-11 10:55
Sub 查找()
Application.ScreenUpdating = False
    Dim i As Integer

你好，，你这个VBA怎么用具体？

江河行地

13958206051 发表于 2015-10-12 09:26
你好，，你这个VBA怎么用具体？

这样

grf1973

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim xRng As Range
   
3.     If Target.Count > 1 Then Exit Sub
   
4.     If Target.Column > 1 Then Exit Sub
   
5.     Set xRng = Sheets("全部产品").[a:a].Find(Target, lookat:=xlWhole)
   
6.     If Not xRng Is Nothing Then Target.Resize(1, 6).Value = xRng.Resize(1, 6).Value Else Target.Offset(0, 1).Resize(1, 5).ClearContents
   
7. End Sub

复制代码

grf1973

A列输入，自动生成BCDEFG各列，这样就可以了吧。如果要A列输入了很多行后一次性生成，可以用数组。

grf1973

用数组批量查找。

1. Sub 查找()
   
2.     Application.ScreenUpdating = False
   
3.     Dim i As Integer
   
4.     arr = Sheets("全部产品").[a1].CurrentRegion
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     brr = Range("a1:f" & Cells(Rows.Count, 1).End(3).Row)
   
7.     For i = 2 To UBound(arr)
   
8.         d(arr(i, 1)) = i
   
9.     Next
   
10.     For i = 2 To UBound(brr)
    
11.         k = d(brr(i, 1))
    
12.         If k > 0 Then
    
13.             For j = 2 To UBound(brr, 2)
    
14.                 brr(i, j) = arr(k, j)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     Range("a1:f" & Cells(Rows.Count, 1).End(3).Row) = brr
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码

13958206051

grf1973 发表于 2015-10-12 10:14
用数组批量查找。

非常感谢，可以用了，谢谢！