[發問] 日期區間查詢(跨年月)

sammay

請問各位前輩：
日期區間查詢應如何實做呢？
例如：在userform1中按下查詢按鈕，再(於userform3中)選擇100年12月到101年1月按下確定按鈕後，將結果輸出到查詢明細？
sh-test1-20120116.rar (36.42 KB)

sh-test1-20120116
下載次數: 32

2012-1-16 08:42

GBKEE

回復 1# sammay
UserForm3

1. Dim 日期()
   
2. Private Sub UserForm_Initialize()
   
3.     CommandButton1.Enabled = False                            '確定鈕控制項: 不可以使用
   
4.     日期 = Array(ComboBox1, ComboBox2, ComboBox3, ComboBox4)  '將年月的輸入 置入在陣列
   
5.     ComboBox1.RowSource = "下拉選單!c2:c11"
   
6.     ComboBox2.RowSource = "下拉選單!d2:d13"
   
7.     ComboBox3.RowSource = "下拉選單!c2:c11"
   
8.     ComboBox4.RowSource = "下拉選單!d2:d13"
   
9. End Sub
   
10. Private Sub CommandButton1_Click()
    
11.     Dim Data As Range, Rng As Range, Day1 As Date, Day2 As Date, Msg As String, E As Range
    
12.     Set Data = Sheets("總表").Range("A3").CurrentRegion
    
13.     'Range("A3").CurrentRegion :   總表的資料 A2:D2 ,E欄 請不要有資料輸入
    
14.     If Data.Rows.Count = 1 Then         '只有欄位
    
15.         MsgBox "總表:  沒有資料 !!!"
    
16.         Unload Me
    
17.         Exit Sub
    
18.     End If
    
19.     Day1 = DateSerial(日期(0), 日期(1), 1)                   '轉入日期
    
20.     Day2 = DateSerial(日期(2), 日期(3), 1)
    
21.     For Each E In Data.Columns(1).Offset(1).Cells             '[A4]->
    
22.         If DateSerial(E, E.Cells(1, 2), 1) >= Day1 And DateSerial(E, E.Cells(1, 2), 1) <= Day2 Then
    
23.             If Rng Is Nothing Then                     '初次
    
24.                 Set Rng = E.Resize(1, 4)
    
25.             Else                                        '第二次以後
    
26.                 Set Rng = Union(Rng, E.Resize(1, 4))
    
27.             End If
    
28.         End If
    
29.     Next
    
30.     Msg = 日期(0) & "/" & 日期(1) & " - " & 日期(2) & "/" & 日期(3)
    
31.     If Rng Is Nothing Then
    
32.         MsgBox Msg & "找不到  資料"
    
33.     Else
    
34.         Rng.Copy Sheets("查詢明細").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    
35.         'Rng 複製到 "查詢明細"A欄 最後一筆有資料的下一格  Offset(1)
    
36.         MsgBox Msg & " 找到  " & Rng.Count / Data.Columns.Count & " 筆資料"
    
37.     End If
    
38.         Unload Me
    
39. End Sub
    
40. Private Sub ComboBox1_Change()
    
41.     Check_日期
    
42. End Sub
    
43. Private Sub ComboBox2_Change()
    
44.      Check_日期
    
45. End Sub
    
46. Private Sub ComboBox3_Change()
    
47.      Check_日期
    
48. End Sub
    
49. Private Sub ComboBox4_Change()
    
50.     Check_日期
    
51. End Sub
    
52. Private Sub Check_日期()      '判別 年月輸入
    
53.     Dim Msg As Boolean, E As Variant
    
54.     For Each E In 日期                          '依序處裡: 年月的輸入
    
55.         If Not IsNumeric(E) Then                '不是數字
    
56.             CommandButton1.Enabled = False      '確定鈕控制項: 不可以使用
    
57.             Msg = True                          'Msg設定為 True
    
58.             Exit For
    
59.         End If
    
60.     Next
    
61.     If Msg = False Then                         '日期皆為數字
    
62.         If DateSerial(日期(0), 日期(1), 1) <= DateSerial(日期(2), 日期(3), 1) Then
    
63.           'DateSerial(年,月, 1)
    
64.             CommandButton1.Enabled = True           '確定鈕控制項: 可以使用
    
65.         Else
    
66.             CommandButton1.Enabled = False          '確定鈕控制項: 不可以使用
    
67.         End If
    
68.     End If
    
69. End Sub

複製代碼

Hsieh

回復 1# sammay

1. Private Sub CommandButton1_Click()
   
2. Dim Ar()
   
3. s = CDate(Val(ComboBox1) + 1911 & "/" & ComboBox2 & "/1"): s1 = CDate(Val(ComboBox3) + 1911 & "/" & ComboBox4 & "/1")
   
4. s1 = DateAdd("m", 1, s1) - 1
   
5. With Sheet1
   
6. For Each a In .Range(.[A4], .[A4].End(xlDown))
   
7. d = DateSerial(a + 1911, a.Offset(, 1), a.Offset(, 2))
   
8. If s <= d And s1 >= d Then
   
9. ReDim Preserve Ar(i)
   
10. Ar(i) = a.Resize(, 4).Value
    
11. i = i + 1
    
12. End If
    
13. Next
    
14. End With
    
15. With Sheet2
    
16. .Select
    
17. .Range(.[A4:D4], .[A4:D4].End(xlDown)) = ""
    
18. If i > 0 Then
    
19. .[A4].Resize(i, 4) = Application.Transpose(Application.Transpose(Ar))
    
20. Else
    
21. MsgBox "無符合資料"
    
22. End If
    
23. End With
    
24. Unload Me
    
25. End Sub
    
26. 
    
27. Private Sub UserForm_Initialize()
    
28. Set d = CreateObject("Scripting.Dictionary")
    
29. With Sheet1
    
30. For Each a In .Range(.[A4], .[A4].End(xlDown))
    
31. d(a.Value) = ""
    
32. Next
    
33. End With
    
34. ComboBox1.List = d.keys
    
35. ComboBox2.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    
36. ComboBox3.List = d.keys
    
37. ComboBox4.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    
38. End Sub

複製代碼

sammay

回復 2# GBKEE
感謝G大回覆，已經可以執行，其中程式碼
Range("A3").CurrentRegion :   總表的資料 A2:D2 ,E欄 請不要有資料輸入
不太明白？

sammay

回復 3# Hsieh
感謝H大回覆，程式碼
s = CDate(Val(ComboBox1) + 1911 & "/" & ComboBox2 & "/1"): s1 = CDate(Val(ComboBox3) + 1911 & "/" & ComboBox4 & "/1")
其中"/1"為何意呢？還有＋1911用意呢？

GBKEE

回復 4# sammay
CurrentRegion 屬性   該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。

1. Sub Ex()
   
2.     With ActiveCell.CurrentRegion.Borders
   
3.         .LineStyle = 1
   
4.         .ColorIndex = 7
   
5.     End With
   
6. End Sub

複製代碼

如圖 的範圍中選取單一有資料的杵存格 執行Ex巨集

下載 (21.51 KB)

2012-1-17 09:18

其中"/1"為何意呢？還有＋1911用意呢？
/1 :            使其日期為每月的1日
＋1911 :  因你的年度是民國, +1911成為西元年度

sammay

回復 6# GBKEE
感謝G大回覆，瞭解。
敬祝 各位先進前輩們 新年快樂 萬事如意 心想事成

JOYARK

謝謝提供學習非常實用

afu9240

回復 6# GBKEE

G大 您好
  如果日期格式為我附件這種類型要如何取日期範圍出來,再貼在新的工作表呢!!! 查詢日期區間資料.zip (31.65 KB)

下載次數: 5

2018-2-27 16:20

Hsieh

回復 9# afu9240

1. Private Sub CommandButton4_Click() '查詢按鈕
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. s = DateValue(ComboBox2 & "/" & ComboBox3 & "/1")
   
4. x = DateAdd("m", 1, DateValue(ComboBox5 & "/" & ComboBox4 & "/1")) - 1
   
5. With 工作表1
   
6. For Each a In .Range(.[A2], .[A2].End(xlDown))
   
7.    If a >= s And a <= x Then
   
8.       d(a.Offset(, 2).Value) = d(a.Offset(, 2).Value) + a.Offset(, 1)
   
9.    End If
   
10. Next
    
11. End With
    
12. With Sheets("總表")
    
13.   For Each a In .[C3:C13]
    
14.      a.Offset(, 1) = d(a.Value)
    
15.   Next
    
16. End With
    
17. End Sub

複製代碼

複本 如何將資料匯入總表.zip (33.03 KB)

下載次數: 10

2018-2-27 17:08