|
Sub 数据匹配()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim rn As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set sh = Sheets("sheet1")
With sh
w = .UsedRange.Rows.Count
x = .UsedRange.Columns.Count
br = .Range(.Cells(1, 1), .Cells(w, x))
End With
With Sheets("sheet2")
r = .Cells(Rows.Count, 4).End(xlUp).Row
y = .Cells(2, Columns.Count).End(xlToLeft).Column
If r < 5 Then MsgBox "导入蔬菜定价 工作表为空,请先导入数据!": End
ar = .Range(.Cells(1, 1), .Cells(r, y))
For j = 5 To y
If ar(2, j) <> "" Then
d(ar(2, j)) = j
End If
Next j
For i = 3 To UBound(ar)
If ar(i, 3) <> "" Then
zd = ar(i, 3)
Set rn = sh.Columns(1).Find(zd, , , , , , 1)
If rn Is Nothing Then MsgBox "数据源中找不到" & zd: End
ks = rn.Row
hs = sh.Cells(ks, 1).MergeArea.Rows.Count
js = ks + hs - 1
ar(i, 5) = br(ks, 4)
For s = ks To js
If br(s, 3) <> "" Then
lh = d(br(s, 3))
If lh <> "" Then
ar(i + 1, lh) = br(s, 5)
ar(i + 2, lh) = br(s, 6)
ar(i + 3, lh) = br(s, 7)
End If
End If
Next s
End If
Next i
.Range(.Cells(1, 1), .Cells(r, y)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|