Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
If .Address = "$C$1" Then
Cancel = True
If [B1] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
Call 搜尋(Array([B1], "", ""), Array(6, 7, 4))
.Interior.ColorIndex = 6: [B1].Interior.ColorIndex = 6
ElseIf .Address = "$C$2" Then
Cancel = True
If [B2] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
Call 搜尋(Array("", [B2], ""), Array(6, 7, 4))
.Interior.ColorIndex = 6: [B2].Interior.ColorIndex = 6
ElseIf .Address = "$C$3" Then
Cancel = True
If [B3] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
Call 搜尋(Array("", "", [B3]), Array(6, 7, 4))
.Interior.ColorIndex = 6: [B3].Interior.ColorIndex = 6
ElseIf .Address = "$A$1:$A$3" Then
Cancel = True
If [B1] & [B2] & [B3] = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
Call 搜尋(Array([B1], [B2], [B3]), Array(6, 7, 4))
.Interior.ColorIndex = 6: [B1:B3].Interior.ColorIndex = 6
End If
End With
End Sub
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 搜尋(Ur1, Ur2)
Dim Sht As Worksheet, xU As Range, xE As Range, k%
Call 清除
For Each Sht In Sheets
If Left(Sht.Name, 4) <> "Data" Then GoTo 101
If Sht.FilterMode Then Sht.ShowAllData
Set xU = Sht.UsedRange
For k = 0 To 2
If Ur1(k) <> "" Then
xU.AutoFilter Field:=Ur2(k), Criteria1:=Ur1(k)
End If
Next k
Set xE = Cells(Rows.Count, 1).End(xlUp)(2)
If xE.Row < 6 Then Set xE = [A6]
xU.Offset(1, 0).Copy xE
Sht.AutoFilterMode = False
101: Next
Set xE = Cells(Rows.Count, 1).End(xlUp)
If xE.Row < 6 Then MsgBox "找不到符合的資料！ ": Exit Sub
[A6:J6].Interior.ColorIndex = 35
[A7:J7].Interior.ColorIndex = 6
[A6:J7].Copy
Range(xE, [J6]).PasteSpecial Paste:=xlFormats
xE(2).EntireRow.Delete
[A6].Select
End Sub
Sub 清除()
With Sheets("Search")
If .FilterMode Then .ShowAllData
With .UsedRange.Offset(5, 0)
.ClearContents
.Interior.ColorIndex = xlNone
End With
.[A1,C1:C3].Interior.ColorIndex = 15
.[B1:B3].Interior.ColorIndex = 35
.[A6].Select
End With
End Sub
作者: 准提部林 時間: 2018-9-14 10:08
改一下[雙擊觸發]部份:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim T1$, T2$, T3$, R As Range, C%
With Target
Select Case .Item(1).Address(0, 0)
Case "C1": T1 = [B1]: Set R = [B1]: C = 1
Case "C2": T2 = [B2]: Set R = [B2]: C = 1
Case "C3": T3 = [B3]: Set R = [B3]: C = 1
Case "A1": T1 = [B1]: T2 = [B2]: T3 = [B3]: Set R = [B1:B3]: C = 1
End Select
If C = 0 Then Exit Sub
Cancel = True
If T1 & T2 & T3 = "" Then MsgBox "未輸入搜尋文字！ ", 0 + 16: Exit Sub
Call 搜尋(Array(T1, T2, T3), Array(6, 7, 4))
Union(.Cells, R).Interior.ColorIndex = 6
End With
End Sub作者: Qin 時間: 2018-9-14 13:03
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
For j = 0 To 2 If IsError(Arr(i, Ur2(j))) Then GoTo 102 '在這位置加這一行 If Ur1(j) <> "" Then If LCase(Arr(i, Ur2(j))) Like LCase(Ur1(j)) = False Then GoTo 102
Next j
Sub Trans_Qty()
Dim R&
With Sheets("Qty on Hand")
If .FilterMode Then .ShowAllData
.UsedRange.Offset(1, 0).EntireRow.Delete
End With
R = Cells(Rows.Count, 1).End(xlUp).Row - 7
If R <= 0 Then Exit Sub
With ['Qty on Hand'!A2:I2].Resize(R)
[A8:I8].Resize(R).Copy .Cells
.Sort Key1:=.Item(6), Order1:=xlAscending, _
Key2:=.Item(3), Order1:=xlAscending, Header:=xlNo
End With
With ['Qty on Hand'!I2].Resize(R)
.Formula = "=IF(F2=F3,""A"",""B"")&TEXT(MID(I1,2,99),""0;-0;0;!0"")+N(H2)"
.Value = .Value
.Replace "A*", "", Lookat:=xlPart
.Replace "B", ""
.NumberFormatLocal = "#,##0;-#,##0"
End With
Application.Goto ['Qty on Hand'!A2]
End Sub作者: 准提部林 時間: 2018-10-16 11:56
稍改
Sub Trans_Qty()
Dim R&
With Sheets("Qty on Hand")
.AutoFilterMode = False
.UsedRange.Offset(1, 0).EntireRow.Delete
End With
R = Cells(Rows.Count, 1).End(xlUp).Row - 7
If R <= 0 Then Exit Sub
With ['Qty on Hand'!A2:I2].Resize(R)
[A8:I8].Resize(R).Copy .Cells
.Sort Key1:=.Item(6), Order1:=xlAscending, _
Key2:=.Item(3), Order1:=xlAscending, Header:=xlNo
End With
['Qty on Hand'!A1:I1].Resize(R + 1).AutoFilter
With ['Qty on Hand'!I2].Resize(R)
.NumberFormatLocal = "#,##0;-#,##0"
'.Formula = "=IF(F2=F3,""A"","""")&TEXT(MID(I1,2,99),""0;-0;0;!0"")+N(H2)" '公式(1)
'.Formula = "=IF(F2=F3,""A"","""")&IF(ROW(A1)=1,0,MID(I1,2,99))+N(H2)" '公式(2)
.Formula = "=IF(F2=F3,"""",SUMIF(F:F,F2,H:H))" '公式(3)
'三種公式任選一個, 資料多, 看哪個快, 選哪個
.Value = .Value
.Replace "A*", "", Lookat:=xlPart '使用公式(3), 可省略這一行
End With
Application.Goto ['Qty on Hand'!A2]
End Sub作者: Qin 時間: 2018-10-17 23:43
謝謝前輩常用不同方式的程式碼讓後輩學習
1.Application.Goto ['Qty on Hand'!A2] 同 Sheets("Qty on Hand").Activate: [A2].Activate
2.[~!~]的陳述方式會因為 Qty on Hand 之間有空格而無法辨識,所以要以單引號前後包住
Sub 關鍵字查詢()
With CreateObject("adodb.connection"): V = Application.Version
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0; "
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0; "
.Open V & "Data Source=" & ThisWorkbook.Path & "\SearchData.xlsx"
'excel 調用adodb 用 sql 時 欄位名稱有"."符號 須改為 "#"號
If Cells(7, 1) <> "" And Cells(6, 1) = "" Then sq = sq & " and [No#] like '%" & Replace(Cells(7, 1), " ", "%") & "%'"
If Cells(7, 1) <> "" And Cells(6, 1) <> "" Then sq = sq & " and [No#] between " & Cells(6, 1) & " and " & Cells(7, 1) ' & "'"
If Cells(7, 2) <> "" And Cells(6, 2) = "" Then sq = sq & " and [Inv#] like '%" & Replace(Cells(7, 2), " ", "%") & "%'"
If Cells(7, 2) <> "" And Cells(6, 2) <> "" Then sq = sq & " and [Inv#] between '" & Cells(6, 2) & "' and '" & Cells(7, 2) & "'"
If IsDate(Cells(7, 3)) Then
If Cells(7, 3) <> "" And Cells(6, 3) = "" Then sq = sq & " and [Date] like '%" & Cells(7, 3) & "%'"
If Cells(7, 3) <> "" And Cells(6, 3) <> "" Then sq = sq & " and Format(Date, 'yyyy-MM-dd') between '" & Format(Cells(6, 3), "yyyy-MM-dd") & "' and '" & Format(Cells(7, 3), "yyyy-MM-dd") & "'"
End If
If Cells(7, 4) <> "" Then sq = sq & " and [Supplier] like '%" & Replace(Cells(7, 4), " ", "%") & "%'"
If Cells(7, 5) <> "" Then sq = sq & " and [Inv#(1)] like '%" & Replace(Cells(7, 5), " ", "%") & "%'"
If Cells(7, 6) <> "" And Cells(6, 6) = "" Then sq = sq & " and [Part No#] like '%" & Replace(Cells(7, 6), " ", "%") & "%'"
If Cells(7, 6) <> "" And Cells(6, 6) <> "" Then sq = sq & " and [Part No#] between '" & Cells(6, 6) & "' and '" & Cells(7, 6) & "'"
If Cells(7, 7) <> "" Then sq = sq & " and [Prod# Name] like '%" & Replace(Cells(7, 7), " ", "%") & "%'"
If Cells(7, 8) <> "" And Cells(6, 8) = "" Then sq = sq & " and [Qty] like '%" & Replace(Cells(7, 8), " ", "%") & "%'"
If Cells(7, 8) <> "" And Cells(6, 8) <> "" Then sq = sq & " and [Qty] between " & Cells(6, 8) & " and " & Cells(7, 8)
If Cells(7, 9) <> "" And Cells(6, 9) = "" Then sq = sq & " and [Amt#] like '%" & Replace(Cells(7, 9), " ", "%") & "%'"
If Cells(7, 9) <> "" And Cells(6, 9) <> "" Then sq = sq & " and [Amt#] between " & Cells(6, 9) & " and " & Cells(7, 9)
If Cells(7, 10) <> "" And Cells(6, 10) = "" Then sq = sq & " and [Total] like '%" & Replace(Cells(7, 10), " ", "%") & "%'"
If Cells(7, 10) <> "" And Cells(6, 10) <> "" Then sq = sq & " and [Total] between " & Cells(6, 10) & " and " & Cells(7, 10)
If sq <> "" Then sq = Mid(sq, 5, 99999)
If sq <> "" Then sq = "select * from [Data$A1:J] where " & sq
If sq = "" Then sq = "select * from [Data$A1:J] "
Sheets("SQL搜尋").Cells(9, 1).Resize(10000, 10).ClearContents
Sheets("SQL搜尋").Cells(9, 1).CopyFromRecordset .Execute(sq)
.Close: End With
End Sub
Sub 清除關鍵字()
Sheets("SQL搜尋").Range("a6:J7").ClearContents
End Sub
