依日期查詢資料～

cmo9020

請教很簡單的VBa一個問題~
小弟用巨集弄不出來....
請教要如何從 Sheet1 中的 B1 輸入日期後
可以查詢Sheet2中的資料？

將該查詢日期資料一筆一筆全部列出來？

謝謝各位大神~

Book1.7z (7.98 KB, 下载次数: 11)

2018-2-6 15:49 上传

点击文件名下载附件

看见星光

Sub A()
    Dim arr, brr, i&, j&, k&, s$
    arr = Sheet2.[a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    s = Format([b1].Value, "yyyymmdd")
    For i = 2 To UBound(arr)
        If arr(i, 1) = s Then
            k = k + 1
            For j = 1 To UBound(arr, 2)
                brr(k, j) = arr(i, j)
            Next
        End If
    Next
    ActiveSheet.UsedRange.Offset(2).ClearContents
    If k > 0 Then [a3].Resize(k, UBound(arr, 2)) = brr
End Sub

看见星光

sheet2表的A列不是日期，是字符串。sheet1表的查询日期是日期。你得把两边的格式统一，要么都转换为yyyymmdd格式的文本，要么都转换为日期。

jackie_929

1. Sub test()
   
2.     Dim brr()
   
3.     With Sheet2.UsedRange
   
4.         arr = .Resize(.Rows.Count - 1, .Columns.Count).Offset(1)
   
5.     End With
   
6.     td = Year([B1]) * 10000 + Month([B1]) * 100 + Day([B1])
   
7.     For i = 1 To UBound(arr)
   
8.         If arr(i, 1) = td Then
   
9.             k = k + 1
   
10.             ReDim Preserve brr(1 To 6, 1 To k)
    
11.             For j = 1 To 6
    
12.                 brr(j, k) = arr(i, j)
    
13.             Next j
    
14.         End If
    
15.     Next i
    
16.     Range([A3], Cells(Rows.Count, 6)).ClearContents
    
17.     [A3].Resize(UBound(brr, 2), 6) = WorksheetFunction.Transpose(brr)
    
18. End Sub

复制代码

cmo9020

jackie_929 发表于 2018-2-6 16:14

抱歉，是我的疏忽
謝謝大神，等等用看看，天冷了，多穿點，感謝謝

cmo9020

jackie_929 发表于 2018-2-6 16:14

請問大神,您的VB碼是正確的~
在請教,Sheet2 頁面,全部改成日期 2018/02/06

要依照日期下去查詢,需要修改哪個地方？
我試做了一下,這個地方有點不懂
td = Year([B1]) * 10000 + Month([B1]) * 100 + Day([B1])

另外在想請教,如果我要查無資料訊息
要怎麼去設定...我看了別人的範例是像下面這樣
在請幫忙一下,謝謝
If ygName = "" Then
    MsgBox "查無該筆資料"
    Range("B1").Select
    Exit Sub
End If

jackie_929

cmo9020 发表于 2018-2-7 12:25
請問大神,您的VB碼是正確的~
在請教,Sheet2 頁面,全部改成日期 2018/02/06

1. Sub test()
   
2.     Dim brr()
   
3.     With Sheet2.UsedRange
   
4.         arr = .Resize(.Rows.Count - 1, .Columns.Count).Offset(1)
   
5.     End With
   
6.     td = [B1]
   
7.     For i = 1 To UBound(arr)
   
8.         If arr(i, 1) = td Then
   
9.             k = k + 1
   
10.             ReDim Preserve brr(1 To 6, 1 To k)
    
11.             For j = 1 To 6
    
12.                 brr(j, k) = arr(i, j)
    
13.             Next j
    
14.         End If
    
15.     Next i
    
16.     Range([A3], Cells(Rows.Count, 6)).ClearContents
    
17.     If k <> 0 Then
    
18.         [A3].Resize(UBound(brr, 2), 6) = WorksheetFunction.Transpose(brr)
    
19.     Else
    
20.         MsgBox "未查询到相应日期的资料"
    
21.         [B1].Select
    
22.     End If
    
23. End Sub

复制代码

cmo9020

jackie_929 发表于 2018-2-7 12:46

謝謝大神，今天才有空回覆，謝謝，太棒了