Sub Daily_Sales()
Dim xR As Range
Dim D1 As Date
Dim strformat As String
Dim splitstr() As String
Dim str As String
On Error Resume Next
Sheets("DAILY SALES").Range("A2:K1000").Clear
str = InputBox("Please Input The Date You Want to Search" & Chr(10) & Chr(10) & "Input Format ""DD/MM/YY""")
splitstr = Split(str, "/")
D1 = DateSerial(CInt(splitstr(2)), CInt(splitstr(1)), CInt(splitstr(0)))
S1$ = Format(D1, "dd/mm/yy")
Set xR = Range("GROUPING!A1:K10000")
With xR
.AutoFilter
.AutoFilter Field:=2, Criteria1:=S1
Range("GROUPING!A1").CurrentRegion.Copy
Sheets("DAILY SALES").Range("A1").PasteSpecial xlValues
.AutoFilter
End With
Sheets("DAILY SALES").Activate
With Range([K2], [A65536].End(xlUp)) 'set borders
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = xlAutomatic
.Font.Size = 18
.Font.Name = "Times New Roman"
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
k = 2 ' for exchange date format
Do Until IsEmpty(Cells(k, 2))
Cells(k, 2).NumberFormatLocal = "dd""/""mm""/""yy;@"
k = k + 1
Loop
Range("A1").Select
End Sub
加個防呆:
Sub Daily_Sales()
Dim Qs$, QQ, R&, DateFmt$, xArea As Range
ReTry:
Qs = InputBox("請輸入要查詢的日期" & Chr(10) & Chr(10) & "輸入規則：DD/MM/YY")
If Qs = "" Then Exit Sub
QQ = Split(Qs & "//", "/")
Qs = 20 & QQ(2) & "/" & QQ(1) & "/" & QQ(0)
If IsDate(Qs) = False Then MsgBox "日期輸入錯誤, 請重新輸入! ": GoTo ReTry
QQ = DateValue(Qs)
'---------------------------------------------
Application.ScreenUpdating = False
Sheets("DAILY SALES").UsedRange.Offset(1, 0).EntireRow.Delete
Set xArea = Range([GROUPING!K1], [GROUPING!A1].Cells(Rows.Count, 1).End(xlUp))
With xArea
.AutoFilter Field:=2, Criteria1:=QQ
.Offset(1, 0).Copy Sheets("DAILY SALES").[A2]
.Parent.ShowAllData
End With
With Sheets("DAILY SALES").UsedRange
R = .Cells(.Rows.Count + 1, 2).End(xlUp).Row
If R = 1 Then MsgBox "找不到符合日期的資料！ ": Exit Sub
.Columns(2).NumberFormatLocal = "dd/mm/yy"
.EntireColumn.AutoFit
End With
End Sub
