怎麼抓儲存格裡"特別的日期"

kasl

小弟想要抓取sheet裡 每個月第一個日期以及最後一個日期
並存到陣列裡 請問這個該怎麼寫
謝謝~

GBKEE

回復 1# kasl

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, AR(), i, S, xMax  As Double, xMin  As Double
   
4.     Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
   
5.     With Sheets("進場記錄表")
   
6.         i = 3   '從A3 開始
   
7.         S = 0
   
8.         Do While .Cells(i, "A") <> ""
   
9.            D(Mid(.Cells(i, "A"), 1, 6)) = "" '前6位: 年份月份
   
10.            ReDim Preserve AR(0 To S)
    
11.            AR(S) = .Cells(i, "A")
    
12.            If Mid(.Cells(i, "A"), 1, 6) <> Mid(.Cells(i + 1, "A"), 1, 6) Then
    
13.                 xMax = Application.WorksheetFunction.Large(AR, 1)
    
14.                 xMin = Application.WorksheetFunction.Small(AR, 1)
    
15.                 D(Mid(.Cells(i, "A"), 1, 6)) = Array(Mid(.Cells(i, "A"), 1, 6), xMin, xMax)
    
16.                 S = 0
    
17.             Else
    
18.                 S = S + 1
    
19.             End If
    
20.             i = i + 1
    
21.         Loop
    
22.     End With
    
23.     With Sheets("Sheet1") '另一工作表
    
24.         .Range("a1").Resize(D.Count, 3) = Application.Transpose(Application.Transpose(D.Items))
    
25.     End With
    
26. End Sub

複製代碼

kasl

感謝~ 小弟來研究一下整個程式的運作過程

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

資料表:

下載 (97.03 KB)

2023-4-18 15:46

結果表:

下載 (122.21 KB)

2023-4-18 15:47

Option Explicit
Sub TEST()
Dim Brr, Y, R&, R1&, i&, T$, Tm$, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([C2], Cells(Rows.Count, "A").End(xlUp)): Brr = xR
For i = 2 To UBound(Brr)
   If i = 2 Then
      R = R + 1: Brr(1, 1) = "月份": Brr(1, 2) = "最早日期": Brr(1, 3) = "最後日期"
   End If
   T = Brr(i, 1): Tm = Val(Brr(i, 1)) \ 100
   If Y(Tm) = "" Then
      R = R + 1: R1 = R: Y(Tm) = R1
      Brr(R1, 1) = Tm: Brr(R1, 2) = T: Brr(R1, 3) = T
      Else
         R1 = Y(Tm)
         If T < Brr(R1, 2) Then Brr(R1, 2) = T
         If T > Brr(R1, 3) Then Brr(R1, 3) = T
   End If
Next
With Workbooks.Add
   .Sheets(1).[A1].Resize(R, 3) = Brr
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub