Sub 出库到明细()
Dim ar As Variant
Dim d As Object
Dim arr()
Set d = CreateObject("scripting.dictionary")
With Sheets("出库录入")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs < 4 Then MsgBox "出库录入为空!": End
br = .Range("a1:n" & rs)
End With
With Sheets("仓储明细")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:x" & r)
For i = 2 To UBound(ar)
If ar(i, 11) <> "" Then
d(ar(i, 11)) = i
End If
Next i
ReDim arr(1 To UBound(ar), 1 To 9)
For j = 16 To 24
arr(1, j - 15) = ar(1, j)
Next j
For i = 2 To UBound(br)
xh = d(br(i, 2))
If xh <> "" Then
arr(xh, 1) = br(2, 1)
arr(xh, 2) = br(2, 3)
arr(xh, 3) = br(2, 5)
arr(xh, 4) = br(2, 8)
arr(xh, 5) = br(2, 11)
arr(xh, 6) = br(2, 13)
arr(xh, 7) = br(2, 14)
arr(xh, 8) = br(i, 13)
arr(xh, 9) = br(i, 14)
End If
Next i
.[p1].Resize(UBound(arr), UBound(arr, 2)) = arr
End With
MsgBox "ok!"
End Sub
|