| |
▼ackkn さん：
>行き詰まり、時間が無く困っています。
>毎年年末になると、荷主様から主要配送先への送り込み予定データが送られてきます。
i今更ですが、2022年末用に。
Sheet2の日付と曜日は、手作業で用意しておいてください。
Option Explicit
Sub test()
Dim r1 As Range, r2 As Range
Dim v, n As Long, w()
Dim dic As Object
Dim s As String, k As Long
Dim d As Long
Set r1 = Sheet1.Range("A1").CurrentRegion
Set r1 = Intersect(r1, r1.Offset(1))
Set r2 = Sheet2.UsedRange.Offset(2)
r2.ClearContents
v = WorksheetFunction.Sort(r1, 3)
n = UBound(v)
ReDim w(n * 2, 1 To r2.Columns.Count + 1)
Set dic = CreateObject("scripting.dictionary")
For k = 1 To n
s = v(k, 3) & vbTab & v(k, 4)
If Not dic.exists(s) Then
dic(s) = dic.Count * 2
w(dic(s), 1) = v(k, 3)
w(dic(s), 2) = v(k, 4)
End If
d = (Day(v(k, 1)) - 13) * 2 + 3
w(dic(s), d) = v(k, 5)
w(dic(s), d + 1) = v(k, 6)
w(dic(s) + 1, d + 1) = v(k, 7)
Next
r2.Resize(dic.Count * 2, UBound(w, 2)).Value = w
End Sub
|
|
マナ
- 22/1/9(日) 19:30 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
