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

Option Explicit
Sub Ex()
Dim AR(), Rng As Range, i As Integer, ii As Integer, iii As Integer, xYear As String, AB As Variant
'**工作表1上有一些函數執行程式時會重新計算,影響執行速度.**
Application.Calculation = xlManual '設定代表計算模式為手動
With 工作表1.Range("A1").CurrentRegion
'**Range.CurrentRegion 屬性傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀的
.Sort key1:=.Cells(1), key2:=.Cells(1, 2), key3:=.Cells(1, 3), Header:=xlYes
'** 資料排序
End With
With 工作表2
.UsedRange.Clear '不必作整個工作表的清除
'**Worksheet.UsedRange 屬性會傳回 Range 物件，此物件代表指定工作表上的已用範圍。唯讀的。
'**篩選出工作表1.Range("Al:A")上不重複的ITEM到.Range("A1")下***
工作表1.Range("A1").CurrentRegion.Columns(1).AdvancedFilter xlFilterCopy, "", .Range("A1"), True
'**Range.AdvancedFilter 方法根據準則範圍，從清單中篩選或複製資料。如果初始選擇為單一儲存格，則會使用儲存格的目前區域。
.Range("C1").Resize(, 2) = Array(工作表1.[A1], 工作表1.[D1])
.Range("C3").Resize(, 3) = Array(工作表1.[A1], 工作表1.[B1], 工作表1.[D1])
Set Rng = .[a2]
xYear = Mid(工作表1.Range("D2"), 1, Len(工作表1.Range("D2")) - 4) '年份
ReDim AR(1 To Rng.End(xlDown).Row, 1 To 49) '**ReDim 陳述式在程序層次中用來重新配置動態陣列變數的儲存空間。
Do
AR(Rng.Row, 1) = Rng '導入ITEM **.Range("A1")下不重複的ITEM**
For i = 1 To 12
'***篩選準則****
.Range("C2") = Rng 'ITEM
.Range("D2") = xYear & Format(i, "00") & "*" '年份&月份
'** 進階篩選**
工作表1.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("C1").Resize(2, 2), CopyToRange:=.Range("C3").Resize(, 3), Unique:=True
If .Range("d4") <> "" Then '篩選出資料
AR(Rng.Row, ((i - 1) * 4) + 2) = .Range("d4") '最小
If .Range("d4").End(xlDown).Row = Rows.Count Then '資料只有一筆
AR(Rng.Row, ((i - 1) * 4) + 3) = .Range("d4") '最大
AR(Rng.Row, ((i - 1) * 4) + 5) = 1 '計數
Else
For iii = .Range("d4") + 1 To .Range("d4").End(xlDown) - 1 '第二最小值 TO 第二最大值的迴圈
AB = Application.Match(Format(iii, "00000"), .Range(.Range("d4"), .Range("d4").End(xlDown)), 0)
If IsError(AB) Then AR(Rng.Row, ((i - 1) * 4) + 4) = IIf(AR(Rng.Row, ((i - 1) * 4) + 4) <> "", AR(Rng.Row, ((i - 1) * 4) + 4) & ",", "'") & Format(iii, "00000")
'AB是錯誤值-> iii為 "01中間漏掉號碼"
Next
AR(Rng.Row, ((i - 1) * 4) + 3) = .Range("d4").End(xlDown) '最大
AR(Rng.Row, ((i - 1) * 4) + 5) = .Range("d4").End(xlDown).Row - 3 '計數
End If
End If
Next
'**檢查月份間的遺漏**
For ii = 3 To UBound(AR, 2) - 4 Step 4
AB = AR(Rng.Row, ii)
Do While AB + 1 < Val(AR(Rng.Row, ii + 3))
AR(Rng.Row, ii + 1) = IIf(AR(Rng.Row, ii + 1) <> "", AR(Rng.Row, ii + 1) & ",", "'") & Format(AB + 1, "00000")
AB = AB + 1
Loop
Next
Set Rng = Rng.Offset(1) '下一個 .Range("A1")下不重複的ITEM
Loop Until Rng = "" 'Until->結束迴圈的條件
.UsedRange.Clear
With .Range("A1")
.Value = "月份"
AR(1, 1) = "項目"
For i = 1 To 12
With .Cells(1, (i - 1) * 4 + 2).Resize(, 4)
.Merge
.NumberFormatLocal = "00"
.HorizontalAlignment = xlCenter
.Value = i
End With
For ii = 0 To 3
AR(1, ii + ((i - 1) * 4) + 2) = Array("最小", "最大", "01中間漏掉號碼", "計數")(ii)
If ii <= 1 Then
.Cells(3, ii + ((i - 1) * 4) + 2).Resize(Rng.Row - 2).NumberFormatLocal = "00000"
End If
Next
Next
.Offset(1).Resize(UBound(AR), UBound(AR, 2)) = AR
End With
End With
Application.Calculation = xlCalculationAutomatic '計算模式為自動
End Sub

複製代碼