[發問] 查詢日期帶出此日期的每筆資料

chyong911

各位前輩好，因為自學VBA，概念沒有很純熟，做到一半卡關了，跪求協助QQ
想要寫一篇可以用"支票到期日"來從資料庫挖出此到期日的每筆支票號(不要重複)及此支票號的傳票單號、兌現日、公司別，但目前我寫的VBA目前只能寫出一筆Orz


我思考出的邏輯示意圖如下(但目前寫不出來)

下載 (170.82 KB)
示意圖

2019-4-25 14:50

寫的VBA為：
PS這一段每次按鈕下去都跑超久，是不是我寫得太不精簡了QQ有更好的方式嗎?
支票查詢.rar (129.42 KB)

下載次數: 9

2019-4-25 15:32

Private Sub 查詢_Click()
'關閉螢幕跳躍
    Application.ScreenUpdating = False
    Sheets("票據簽收單").Select
   
    '匯出欄位使用
    Dim NumberColumn, DayColumn, SummonsColumn, BusinessColumn As Integer '支票號 '到期日'傳票單號'公司別
    X = Sheets("票據簽收單").Cells(9, "W") '輸入到期日
   
    '預設欄位位子
    NumberColumn = 6
    DayColumn = 6
    BusinessColumn = 6
    SummonsColumn = 6
   
   
    '清空查詢結果
    ClearFunction
   
    '執行查詢
For i = 3 To 1000 'data上限1000筆

        'InStr會傳回 Variant (Long)，指定另一個字串內某個字串的第一個出現位置。
        'InStr([ start ], string1, string2, [ compare ])
        'If Sheets("系統設定").Cells(i, "D").Contains(x) Then
        
    If InStr(Sheets("應付票據data").Cells(i, "C"), X) > 0 Then '找到第一格資料
           'Value
           r = Sheets("應付票據data").Cells(i, "AC").Row
           v = Sheets("應付票據data").Cells(i, "AC").Value
           For p = 0 To v - 1
            Sheets("票據簽收單").Cells(SummonsColumn, "X") = Sheets("應付票據data").Cells(i, "C") '傳票單號
            Sheets("票據簽收單").Cells(NumberColumn, "Y") = Sheets("應付票據data").Cells(i, "V") '支票號
            Sheets("票據簽收單").Cells(DayColumn, "z") = Sheets("應付票據data").Cells(i, "Y") '到期日
            Sheets("票據簽收單").Cells(BusinessColumn, "aa") = Sheets("應付票據data").Cells(i, "D") '公司別
            Next
            p = p + 1
     End If
Next
   
    NumberColumn = NumberColumn + 1
    DayColumn = DayColumn + 1
    SummonsColumn = SummonsColumn + 1
    BusinessColumn = BusinessColumn + 1
   
    Sheets("票據簽收單").Select
End Sub
------------------------------------------------------------------------------------
Private Sub 清除查詢_Click()
'關閉螢幕跳躍
    Application.ScreenUpdating = False
    Sheets("票據簽收單").Range("X6:AA17").ClearContents
    Sheets("票據簽收單").Cells(6, "W").ClearContents
    Sheets("票據簽收單").Cells(9, "W").ClearContents
   
End Sub
--------------------------------------------------------------------------------------
Private Sub ClearFunction()
    '關閉螢幕跳躍
    Application.ScreenUpdating = False
    Sheets("票據簽收單").Range(Cells(6, 24), Cells(12, 29)).ClearContents

End Sub



以上麻煩版上的各位前輩指教了Orz

GBKEE

回復 1# chyong911
試試看

1. Private Sub 查詢_Click()
   
2.     Dim Sh(1 To 2) As Worksheet, Rng(1 To 2) As Range, P As Integer, i As Integer
   
3.     Dim Ar()
   
4.    
   
5.     Application.ScreenUpdating = False ''關閉螢幕跳躍
   
6.     Set Sh(1) = Sheets("票據簽收單")
   
7.     Set Sh(2) = Sheets("應付票據data")
   
8.    
   
9.     Set Rng(1) = Sh(1).Range("W6") '到期日
   
10.     Set Rng(2) = Sh(2).Range("C3") '庫傳票單號
    
11.    
    
12.     If Rng(2) = "" And Rng(2).End(xlDown).Row = Rows.Count Then
    
13.         MsgBox "應付資料 中  沒有 庫傳票單號"
    
14.         Exit Sub
    
15.     End If
    
16.     ClearFunction ''清空查詢結果
    
17.    
    
18.     '執行查詢
    
19.     P = 1
    
20.     Ar = Array("C", "V", "Y", "D") '應付票據data 要導入的欄位
    
21.     Do While Rng(2) <> ""      '庫傳票單號不為空值
    
22.         If InStr(Rng(2), Rng(1)) Then '找到輸入到期日
    
23.             For i = 1 To 4    'X,Y,Z,AA 欄位
    
24.                 Rng(1).Cells(P, i + 1) = Sh(2).Cells(Rng(2).Row, Ar(i - 1))
    
25.             Next
    
26.             P = P + 1    '查詢到 +1 列位
    
27.         End If
    
28.         Set Rng(2) = Rng(2).Offset(1)  '下一個庫傳票單號
    
29.     Loop
    
30.     Application.ScreenUpdating = True
    
31. End Sub

複製代碼