- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
23#
發表於 2018-8-27 10:05
| 只看該作者
本帖最後由 GBKEE 於 2018-8-31 08:35 編輯
回復 22# s7659109
適用 求每月最大與最小NO之計算0822進階版.xlsm
試試看- 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
|
|
發表於 2018-8-24 21:54
| 
發表於 2018-8-24 22:50
| 
