麻辣家族討論版版 - Powered by Discuz! Board

Sub Ex()
Dim D(2) As Object, R As Variant, AR()
Set D(0) = CreateObject("Scripting.Dictionary")
Set D(1) = CreateObject("Scripting.Dictionary")
Set D(2) = CreateObject("Scripting.Dictionary")
With Sheets("出貨單")
For Each R In .Range(.[B12], .[G29]).Rows '出貨單內容範圍-> 的整列
If Application.CountA(R) = 6 Then '資料要齊全
AR = Array(.[G4].Text, .[G5], .[B5], R.Cells(1, 1), R.Cells(1, 2), R.Cells(1, 3), R.Cells(1, 5), R.Cells(1, 6))
D(1)(Join(AR, ",")) = AR
End If
Next
End With
With Sheets("出貨單歷史統計")
For Each R In .Range(.[A3], .Cells(Rows.Count, "H").End(xlUp)).Rows
If Application.CountA(R) = 8 Then D(0)(Join(Application.Transpose(Application.Transpose(R.Value)), ",")) = ""
D(2)(R.Cells(1, 1) & R.Cells(1, 2)) = D(2)(R.Cells(1, 1) & R.Cells(1, 2)) + R.Cells(1, 8)
Next
For Each R In D(1).KEYS
If D(0).EXISTS(R) = False Then
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Resize(, 8) = D(1)(R)
D(2)(.Cells(1) & .Cells(1, 2)) = D(2)(.Cells(1) & .Cells(1, 2)) + .Cells(1, 8)
End With
End If
Next
For Each R In .Range(.[A3], .Cells(Rows.Count, "A").End(xlUp))
If D(2).EXISTS(R & R(1, 2)) Then R(1, 9) = D(2)(R & R(1, 2))
Next
End With
Set D(0) = Nothing
Set D(1) = Nothing
Set R = Nothing
End Sub

複製代碼

Sub inputdata() '儲存資料
Dim Rng As Range, Ay()
With Sheet1
Set Rng = .Range("A12:A29")
If Application.CountA(Rng) > 0 Then
For Each a In Rng.SpecialCells(xlCellTypeConstants)
ar = Array(.[G5].Value, .[G4].Value, .[B5].Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, a.Offset(, 5).Value, a.Offset(, 6).Value)
ReDim Preserve Ay(s)
Ay(s) = ar
s = s + 1
Next
cnt = .[G32].Value
With Sheet2
Set a = .[A65536].End(xlUp).Offset(1)
a.Resize(s, 8) = Application.Transpose(Application.Transpose(Ay))
a.Offset(s - 1, 8) = cnt
End With
End If
End With
End Sub
Function PaperNo(Rng As Range, mydate As Date, k) '流水編號
Set d = CreateObject("Scripting.Dictionary")
mystr = Format(mydate, "yyyymmdd")
If Application.CountA(Rng) > 0 Then
For Each a In Rng.SpecialCells(xlCellTypeConstants)
If Left(a, 8) = mystr Then d(Val(a)) = ""
Next
End If
If d.Count > 0 Then
PaperNo = IIf(k = 1, Format(Application.Max(d.keys) + 1, "00000000000"), Format(Application.Max(d.keys), "00000000000"))
Else
PaperNo = mystr & "001"
End If
End Function

複製代碼