Board logo

標題: [發問] 查詢日期帶出此日期的每筆資料 [打印本頁]

作者: chyong911    時間: 2019-4-25 15:31     標題: 查詢日期帶出此日期的每筆資料

本帖最後由 chyong911 於 2019-4-25 15:33 編輯

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


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

寫的VBA為:
PS這一段每次按鈕下去都跑超久,是不是我寫得太不精簡了QQ有更好的方式嗎?
[attach]30468[/attach]

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    時間: 2019-5-2 11:05

回復 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
複製代碼





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