返回列表 上一主題 發帖

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

chyong911

帖子
6 
主題
3 
精華
0 
積分
14 
點名
0  
作業系統
WIN10 
軟體版本
Office 2010 
閱讀權限
10 
性別
女 
註冊時間
2018-5-23 
最後登錄
2019-4-30 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2019-4-25 15:31 | 只看該作者

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

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

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


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


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

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

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 【時日莫空過】一個人在世間做了多少事，就等於壽命有多長。因此必須與時間競爭，切莫使時日空過。
返回列表 上一主題