|
Sub 一列2行参考()
Dim sht As Worksheet, n As Integer, iFlag As Boolean
Dim ShtName() As String
Application.DisplayAlerts = False
For Each sht In Sheets
If sht.Name <> "销售" And sht.Name <> "拣配单" And sht.Name <> "拣配单 (2)" Then sht.Delete
Next
Application.DisplayAlerts = True
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.UsedRange
For i = 2 To UBound(arr)
zu = arr(i, 11)
If zu <> "" Then d(zu) = d(zu) & "," & i
Next
Application.ScreenUpdating = False
rmax = 2
For Each zu In d.keys
m = m + 1
xrr = Split(d(zu), ",")
rs = UBound(xrr)
If rs Mod 2 = 0 Then
n = (rs - 0.1) \ rmax
Else
n = (rs - 0.1) \ rmax + 1
End If
For pg = 1 To n
Sheets("拣配单").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = zu & "-" & pg
ReDim brr(1 To rmax, 1 To UBound(arr, 2))
s = (pg - 1) * 2
For r = 1 To rmax
If r + s <= rs Then
i = xrr(r + s)
brr(r, 1) = r
brr(r, 2) = arr(i, 18)
brr(r, 3) = arr(i, 12)
brr(r, 4) = arr(i, 17)
End If
Next
.[A9].Resize(2, 10) = brr
End With
Next
Next
Sheets("拣配单").Activate
Application.ScreenUpdating = True
End Sub |
|