|
|
发表于 2015-1-14 22:23
来自手机
|
显示全部楼层
'全部放在模块中
Sub 前期准备() '代码目的是如果生产编号前三位是数字则去掉,便于后期查找,不是则保持不变
Worksheets(2).Activate
Dim rng As Range, arr, i As Integer, rown As Integer
'对数据进行相关处理,便于查找
Set rng = Sheets(2).Range([a2], Cells(Rows.Count, 1).End(xlUp))
rown = rng.Rows.Count
For i = 2 To rown + 1
a = Cells(i, 1).Value
If CStr(Left(a, 1)) Like "[0-9]" Then
Cells(i, 1).Offset(0, Columns.Count - 1).Value = Right(a, Len(a) - 3)
Else
Cells(i, 1).Offset(0, Columns.Count - 1).Value = a
End If
Next i
End Sub
Sub 准备2() '在sheet1 中运行,代码的目的是去掉本厂编号中的重复值
Worksheets(1).Activate
Dim rng As Range, a As Range
Set rng = Range([a2], Cells(Rows.Count, 1).End(xlUp))
On Error Resume Next
With CreateObject("scripting.dictionary")
For Each a In rng
If Len(a) > 0 Then .Add (CStr(a)), ""
Next a
Sheets(2).Range("iu1").Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
End With
End Sub
Sub 查找() '在sheet2中执行
Application.ScreenUpdating = False
Call 前期准备
Call 准备2
Worksheets(2).Activate
Dim rng As Range, arr, arr2(), j As Integer
i = Sheets(2).Range([a2], Cells(Rows.Count, 1).End(xlUp)).Rows.Count
arr = Sheets(2).Cells(2, Columns.Count).Resize(i, 1).Value
'开始查找
Dim first As Range
Set rng = Sheets(2).Range([iu2], Cells(Rows.Count, "iu").End(xlUp))
For j = 1 To UBound(arr)
ReDim Preserve arr2(1 To 1, 1 To j)
Set first = rng.Find(what:=arr(j, 1), LookIn:=xlValues, lookat:=xlPart)
If Not first Is Nothing Then
arr2(1, j) = first.Value
Else
arr2(1, j) = "未查到相关数据"
End If问
Next j
Sheets(2).Range("b2").Resize(j - 1, 1) = WorksheetFunction.Transpose(arr2)
[iv:iu].Clear
Application.ScreenUpdating = True
End Sub
问题描述的不太清楚，我就按照自己的理解做了下，代码有些长，为了让你更好理解，分三段写成，全部放进模块里执行就好
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
