- 帖子
- 2805
- 主題
- 10
- 精華
- 0
- 積分
- 2861
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-5-4
|
56#
發表於 2018-9-30 21:03
| 只看該作者
回復 55# Qin
Sub Search_Data(Ur1, Ur2)
Dim Sht As Worksheet, Arr, Brr, i&, j%, k%, N&, dd&
Dim Mybook As Workbook, xB As Workbook, xChk%
Call Clear_All
xN = "Data.xls": Set Mybook = ThisWorkbook
On Error Resume Next: Set xB = Workbooks(xN): On Error GoTo 0
If xB Is Nothing Then
Application.ScreenUpdating = False
Set xB = Workbooks.Open("C:\Users\Ms Tan\Desktop\Data.xls", , 1, , "1234")
Mybook.Activate: xChk = 1
End If
'----------------------------
ReDim Brr(1 To 400000, 1 To 10) '若資料會超過6萬筆,自行更改
For Each Sht In xB.Sheets
If LCase(Left(Sht.Name, 4)) <> "data" Then GoTo 101
Arr = Range(Sht.[J2], Sht.Cells(Rows.Count, 1).End(xlUp))
For i = 1 To UBound(Arr)
For j = 0 To 2
If Ur1(j) <> "" Then If LCase(Arr(i, Ur2(j))) Like LCase(Ur1(j)) = False Then GoTo 102
Next j
dd = 0
If IsDate(Arr(i, 3)) Then dd = Arr(i, 3)
If dd < Ur1(3) Then GoTo 102
N = N + 1
For k = 1 To UBound(Brr, 2): Brr(N, k) = Arr(i, k): Next
102: Next i
101: Next
If xChk = 1 Then xB.Close 0
'----------------------------
If N = 0 Then MsgBox "找不到符合資料!": Exit Sub
With [A8:J8].Resize(N)
.Value = Brr
.Sort Key1:=.Item(3), Order1:=xlDescending, Header:=xlNo
[A4:J5].Copy
.Cells.PasteSpecial Paste:=xlFormats
End With
[A6].Select
End Sub
Sub Clear_All()
With Sheets("Search")
If .FilterMode Then .ShowAllData
With .UsedRange.Offset(7, 0)
.ClearContents
.Interior.ColorIndex = xlNone
End With
.[A1,C1:C3].Interior.ColorIndex = 15
.[B1:B3].Interior.ColorIndex = 35
.[A6].Select
End With
End Sub
 Sent_01.rar (135.54 KB)
|
|
發表於 2018-10-3 23:02
| 
發表於 2018-10-1 10:57
| 
