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

標題: [求助] 請高手求助，如何用vba查找資料庫中的資料記錄？ [打印本頁]

作者: maiko 時間: 2012-9-18 17:05 標題: [求助] 請高手求助，如何用vba查找資料庫中的資料記錄？

[attach]12522[/attach]1. 客戶：h001，品名：b2，歷年來的總金額。

[attach]12523[/attach]

2. 客戶：h001，歷年來的總金額。

[attach]12524[/attach]
3. 應該是2012年8月份，客戶：h001，品名：b2，總金額。

[attach]12525[/attach]
4. 應該是2012年8月份，客戶：h001，總金額。

[attach]12526[/attach]

5. 應該是2012年8月份，品名：a1，總金額。

[attach]12527[/attach]

6. 應該是2012年8月份，總金額。

[attach]12528[/attach]

7. 2012年全年總金額。

[attach]12529[/attach]

8. 2012年，客戶：h001，全年總金額。

[attach]12530[/attach]

9. 2012年，客戶：h001，品名：a1，全年總金額。

這樣的一個交叉查詢資料庫，請問用vba如何實現？感激各位賜教。

作者: maiko 時間: 2012-9-18 17:08

回復 1# maiko

補上附件
[attach]12532[/attach]

作者: Hsieh 時間: 2012-9-18 20:16

回復 2# maiko

Sub Search_Data()
d = [A2]
[A2] = IIf([A2] >= 1 And [A2] <= 12, "=MONTH(Sheet2!A2)=" & d, IIf(d = "", "", "=YEAR(Sheet2!A2)=" & d))
[A1] = IIf([A2] <> "", "", "日期")
With Sheet2
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Sheet1.[A1:C2], Sheet1.[A6:D6], False
End With
Cells(Rows.Count, 3).End(xlUp).Offset(2).Resize(, 2) = Array("總共:", "=SUM(R7C:R[-1]C)")
[A2] = d
[A1] = "日期"
End Sub

複製代碼

作者: maiko 時間: 2012-9-19 08:15

可惜不夠積分，不能下載！

作者: maiko 時間: 2012-9-19 08:18

回復 maiko
Hsieh 發表於 2012-9-18 20:16

[attach]12536[/attach]

剛剛發現一個問題，就是應該把日期的年月日分開來查詢，這樣才能夠準確一點，能否改成如果只輸入年，月日不輸入的話就查詢整年的資料，年月同時輸入的話就查詢當年當月的資料，年月日就指定這天查詢的資料，其它客戶、品名沒變。看看能否改一改？謝謝！

能否用vba作一個從Sheet2數據庫裡查詢不重複的客戶名、品名的下拉列表，可讓使用者容易的選擇客戶名、品名，不至於打錯字。謝謝！

最後，能否加一條，如果查詢不到資料，就提供使用者沒此資料？謝謝！

作者: Hsieh 時間: 2012-9-19 09:27

回復 5# maiko
進階查詢，在一般模組

Sub Search_Data()
With Sheet1
y = .[A2]: m = .[B2]: d = .[C2]
.[A2] = IIf(.[A2] = "", "", "=YEAR(Sheet2!A2)=" & y)
.[B2] = IIf(.[B2] = "", "", "=MONTH(Sheet2!A2)=" & m)
.[C2] = IIf(.[C2] = "", "", "=DAY(Sheet2!A2)=" & d)
With Sheet2
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Sheet1.[A1:E2], Sheet1.[A6:D6], False
End With
If .[A7] = "" Then
MsgBox "無資料"
Else
.Cells(.Rows.Count, 3).End(xlUp).Offset(2).Resize(, 2) = Array("總共:", "=SUM(R7C:R[-1]C)")
End If
.[A2] = y
.[B2] = m
.[C2] = d
End With
End Sub

複製代碼

取得Sheet2工作表B、C欄不重複清單做為驗證清單
Sheet2工作表模組

Private Sub Worksheet_Change(ByVal Target As Range)
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
If Target.Column = 2 Or Target.Column = 3 Then
For Each a In Range([B2], Cells(Rows.Count, 2).End(xlUp)).SpecialCells(xlCellTypeConstants)
d(a.Value) = ""
d1(a.Offset(, 1).Value) = ""
Next
With Sheet1
With .Range("D2").Validation
.Delete
.Add xlValidateList, , , Join(d.keys, ",")
End With
With .Range("E2").Validation
.Delete
.Add xlValidateList, , , Join(d1.keys, ",")
End With
End With
End If
End Sub

複製代碼

Sheet2工作表B、C欄有變動時，Sheet1工作表[D2]、[E2]的驗證清單就會改變

作者: maiko 時間: 2012-9-20 10:11

回復 maiko
進階查詢，在一般模組取得Sheet2工作表B、C欄不重複清單做為驗證清單
Sheet2工作表模組Shee ...
Hsieh 發表於 2012-9-19 09:27

謝謝大大提供這麼好的vba語言，只是分數太低，無法下載原件測試，只好拿大大的vba去慢慢啄磨，謝謝！

如遇有什麼問題，容後再提，可以嗎？謝謝！

作者: maiko 時間: 2012-9-20 16:26

回復 maiko
進階查詢，在一般模組取得Sheet2工作表B、C欄不重複清單做為驗證清單
Sheet2工作表模組Shee ...
Hsieh 發表於 2012-9-19 09:27

在試過以Sheet2查詢不重複清單時，Sheet1的A2，B2，C2，D2，E2儲存格只有D2，E2出現清單，其它沒出現，而且D2，E2出現的清單並不是以Sheet2表中查詢的不重複清單，請查看附件是否有沒錯?謝謝！

[attach]12567[/attach]

作者: Hsieh 時間: 2012-9-20 19:35

回復 8# maiko

你把代碼放錯工作表模組
要放在Sheet2工作表模組內
然後變動B、C欄資料
只有D2、E2有驗證，是因為進階篩選準則範圍目前只有A1:E2
其他部分並不需要驗證清單，若你有需求只要把範圍改一下就好

作者: maiko 時間: 2012-9-24 10:28

回復 maiko

你把代碼放錯工作表模組
要放在Sheet2工作表模組內
然後變動B、C欄資料
只有D2、 ...
Hsieh 發表於 2012-9-20 19:35

你好，我把代碼放在Sheet2工作表模組內，然後變動B、C欄，可是還是無法驗證出D、E欄的資料，請查一查附件。
由於無法下載大大提供的附件，請幫忙看看，謝謝！

[attach]12598[/attach]

作者: maiko 時間: 2012-9-25 11:33

大大，能否幫我看看，謝謝！

作者: Hsieh 時間: 2012-9-25 15:09

回復 11# maiko

在Sheet2中的B、C欄隨便打個資料看看

作者: maiko 時間: 2012-9-26 10:22

回復 maiko

在Sheet2中的B、C欄隨便打個資料看看
Hsieh 發表於 2012-9-25 15:09

果然可以啦！
不過能否把清單的順序排為升序嗎？謝謝！

作者: maiko 時間: 2012-9-26 11:15

回復 maiko

在Sheet2中的B、C欄隨便打個資料看看
Hsieh 發表於 2012-9-25 15:09

補充一下：
能否通過Sheet1表中的A2、B2、C2儲存格的改變而令到D2、E2儲存格的清單改變？謝謝！

作者: Hsieh 時間: 2012-9-26 20:41

回復 14# maiko

[attach]12610[/attach]
sheet1模組

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, [A2:C2]) Is Nothing Then CreateList
Application.EnableEvents = True
End Sub

複製代碼

一般模組

Sub Search_Data_New()
Application.ScreenUpdating = False
Application.EnableEvents = False
With Sheet1
y = .[A2]: m = .[B2]: d = .[C2]
.[A2] = IIf(.[A2] = "", "", "=YEAR(Sheet2!A2)=" & y)
.[B2] = IIf(.[B2] = "", "", "=MONTH(Sheet2!A2)=" & m)
.[C2] = IIf(.[C2] = "", "", "=DAY(Sheet2!A2)=" & d)
With Sheet2
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Sheet1.[A1:E2], Sheet1.[A6:D6], False
End With
If .[A7] = "" Then
MsgBox "無資料"
Else
.Cells(.Rows.Count, 3).End(xlUp).Offset(2).Resize(, 2) = Array("總共:", "=SUM(R7C:R[-1]C)")
End If
.[A2] = y
.[B2] = m
.[C2] = d
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub CreateList()
Dim A As Range
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
With Sheet1
y = .[A2]: m = .[B2]: d = .[C2]
.[A2] = IIf(.[A2] = "", "", "=YEAR(Sheet2!A2)=" & y)
.[B2] = IIf(.[B2] = "", "", "=MONTH(Sheet2!A2)=" & m)
.[C2] = IIf(.[C2] = "", "", "=DAY(Sheet2!A2)=" & d)
With Sheet2
.[F1:G1] = .[B1:C1].Value
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Sheet1.[A1:C2], .[F1:G1], True
r = .Range("F1").CurrentRegion.Rows.Count
With .Range(.[F1], .[F1].End(xlDown))
.Sort key1:=.Cells(1, 1), Header:=xlYes
If r > 1 Then
For Each A In .Cells(1).Offset(1).Resize(.Count - 1, 1)
dic(A.Value) = ""
Next
End If
.Clear
End With
With .Range(.[G1], .[G1].End(xlDown))
.Sort key1:=.Cells(1, 1), Header:=xlYes
If r > 1 Then
For Each A In .Cells(1).Offset(1).Resize(.Count - 1, 1)
dic1(A.Value) = ""
Next
End If
.Clear
End With
End With
With .Range("D2").Validation
.Delete
If r > 1 Then .Add xlValidateList, , , Join(dic.keys, ",")
End With
With .Range("E2").Validation
.Delete
If r > 1 Then .Add xlValidateList, , , Join(dic1.keys, ",")
End With
.[A2] = y
.[B2] = m
.[C2] = d
End With
End Sub

複製代碼

作者: maiko 時間: 2012-9-27 09:14

回復 maiko

sheet1模組一般模組
Hsieh 發表於 2012-9-26 20:41

大大，真是感謝你的幫忙，試過代碼，還真行！

不過還有一點點錯誤，大大能否幫忙改一下，就是，如果在選定了A2、B2、C2之後，如果D2也選定的話，那麼E2能否隨著D2的選擇而出現對應的清單內容？

感謝！

作者: maiko 時間: 2012-9-27 09:31

回復 maiko

sheet1模組一般模組
Hsieh 發表於 2012-9-26 20:41

我覺得好像要求越來越多似的，我有點覺得不好意思，不過還剩下一點點東西要大大再幫幫忙，就這麼一點點東西了，如果弄好那就完美了，不知道大大能否再動手幫忙修改一下，真是感激不盡！

就是能否把A2、B2、C2也改成數據庫裡存在的日期清單？
選定了A2，那麼B2、C2、D2、E2也就跟著改變清單內容；
選定了A2、B2，那麼C2、D2、E2也就跟著改變清單內容；
如此類推，如果選定了某兩個或者三個的話，那麼其餘的也跟隨改變清單內容；
就是這麼的一個交叉查詢、互為改變的一個聯級清單，搞定了，那麼這個數據庫就完成了。

感激大大的盛情幫忙！在此拜謝！千萬別嫌在下麻煩。感謝！

作者: maiko 時間: 2012-9-28 11:56

請大大幫幫忙，拜託一下，拜謝了!

作者: maiko 時間: 2012-9-29 06:29

回復 maiko

sheet1模組一般模組
Hsieh 發表於 2012-9-26 20:41

Hsieh大，請你一定要幫忙修改一下，麻煩你了。

請把A2、B2、C2也改成數據庫裡存在的日期清單？
選定了A2，那麼B2、C2、D2、E2也就跟著改變清單內容；
選定了A2、B2，那麼C2、D2、E2也就跟著改變清單內容；
餘此類推，如果選定了某兩個或者三個的話，那麼其餘的也跟隨改變清單內容；
就是這麼的一個交叉查詢、互為改變的一個聯級清單。

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)