[發問] excel 自動篩選依照另外一個工作表的內容 篩選, VBA

ljuber

請問各位大大 我有個經常性的工作

我有錄製巨集並且小小修改 但是有下面幾項不知道要怎麼修改：

1.可以從檔案總管選擇文字檔案匯入

2.篩選條件在 設定工作表的A2:A4 (此範圍會變動)
  (是依照tab分隔 會在第五欄)

3.複製完後文字檔案會自動關閉

4.把篩選後的資料貼到資料工作表，資料會一直往下加下去

(附上檔案） 練習.zip (346.84 KB)

下載次數: 12

2016-1-21 11:17

錄製的巨集：
Sub Macro1()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set MainSh = Workbooks("練習.xlsm")
    abc = Sheets("資料").Range("A1").End(xlDown).Row
    Workbooks.OpenText Filename:="D:\10412-ai201.txt", Origin:=950, Tab:=True, TrailingMinusNumbers:=True
    Columns("A:G").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$G$111784").AutoFilter Field:=5, _
    Criteria1:=Array("11001", "11005", "11009"), Operator:=xlFilterValues
    Selection.Copy
    MainSh.Sheets("資料").Activate
    Range("A" & abc + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
End Sub

Joforn

回復 1# ljuber

1. Private Sub StartLoadText()
   
2.     Const ColumnsNum As Long = 7
   
3.     Dim strFind   As String
   
4.     Dim Value()   As Variant, valRow() As String
   
5.     Dim StartRow  As Long
   
6.     Dim textFile  As String
   
7.     Dim bytArr()  As Byte
   
8.     Dim I As Long, J As Long
   
9.     Dim TextFileName As Variant
   
10.     Dim RegExp    As Object
    
11.     Dim Matchs    As Object
    
12.    
    
13.     On Error Resume Next
    
14.     Set RegExp = CreateObject("VBScript.RegExp")
    
15.     If RegExp Is Nothing Then Exit Sub
    
16.     TextFileName = Application.GetOpenFilename(FileFilter:="Text File,*.TXT", FilterIndex:=1, Title:="Please Change a Text File")
    
17.     StartRow = Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row
    
18.     If StartRow < 2 Then Exit Sub
    
19.     If VarType(TextFileName) = vbString Then
    
20.         I = FileLen(TextFileName)
    
21.         If I < 1 Then Exit Sub
    
22.         ReDim bytArr(0 To I - 1)
    
23.         I = FreeFile
    
24.         Open TextFileName For Binary As I
    
25.         Get I, , bytArr()
    
26.         Close I
    
27.         textFile = StrConv(bytArr, vbUnicode)
    
28.         Erase bytArr
    
29.         With RegExp
    
30.             .Global = True
    
31.             .IgnoreCase = True
    
32.             If StartRow > 2 Then
    
33.                 .Pattern = "(\S+\t){4}((" & Join(Application.WorksheetFunction.Transpose(Sheet2.Range("A2:A" & StartRow).Value), ")|(") & "))(\t.+)*"
    
34.             Else
    
35.                 .Pattern = "(\S+\t){4}(" & Sheet2.Range("A2").Value & ")(\t.+)*"
    
36.             End If
    
37.             Set Matchs = .Execute(textFile)
    
38.         End With
    
39.         With Matchs
    
40.             ReDim Value(0 To .Count - 1, 0 To ColumnsNum - 1)
    
41.             For I = 0 To .Count
    
42.                 valRow = Split(.Item(I), vbTab)
    
43.                 For J = 0 To ColumnsNum - 1
    
44.                   Value(I, J) = valRow(J)
    
45.                 Next J
    
46.             Next I
    
47.         End With
    
48.         Set Matchs = Nothing: Set RegExp = Nothing
    
49.         StartRow = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
    
50.         StartRow = StartRow + 1
    
51.         Application.ScreenUpdating = False
    
52.         Sheet1.Range("A" & StartRow).Resize(I - 1, ColumnsNum).Value = Value
    
53.         Application.ScreenUpdating = True
    
54.     End If
    
55. End Sub

複製代碼

運行附件 練習.zip (350.79 KB)

下載次數: 5

2016-1-22 00:40

中的按鈕：

c_c_lai

回復 1# ljuber
試試看：

1. Option Explicit
   
2. 
   
3. Sub Ex()
   
4.     Dim loc As Long, cts As Long, txtFile As String, arr() As String, sp() As String
   
5.    
   
6.     Application.DisplayAlerts = False
   
7.     Application.ScreenUpdating = False
   
8.    
   
9.     txtFile = Application.GetOpenFilename("(*.txt), *.txt")
   
10.     If txtFile = "" Then Exit Sub
    
11.    
    
12.     sp = Split(txtFile, "\")
    
13.     With Workbooks("練習.xlsm")
    
14.         cts = .Sheets("設定").Range("A1").End(xlDown).Row
    
15.         
    
16.         ReDim Preserve arr(cts - 1)       '  動態地處理 arr 陣列帶入之陣列值。
    
17.         For loc = 2 To cts
    
18.            arr(loc - 1) = .Sheets("設定").Range("A" & loc).Text   '
    
19.         Next loc
    
20.         
    
21.         loc = .Sheets("資料").Range("A1").End(xlDown).Row
    
22.         '  Workbooks.OpenText Filename:=ThisWorkbook.Path & "\10412-ai201.txt", Origin:=950, Tab:=True, TrailingMinusNumbers:=True
    
23.         Workbooks.OpenText Filename:=txtFile, Origin:=950, Tab:=True, TrailingMinusNumbers:=True
    
24.       
    
25.         ActiveSheet.Range("A:G").AutoFilter Field:=5, _
    
26.             Criteria1:=arr, Operator:=xlFilterValues
    
27.             '  動態地處理 Criteria1 帶入之值。
    
28.             '  Criteria1:=Array("11001", "11005", "11009"), Operator:=xlFilterValues
    
29.         Columns("A:G").Copy
    
30.         .Sheets("資料").Range("A" & loc + 1).PasteSpecial Paste:=xlPasteValues
    
31.         
    
32.         '  Workbooks("10412-ai201.txt").Close
    
33.         Workbooks(sp(UBound(sp))).Close
    
34.         '  .Sheets("資料").Range("A" & loc + 1).Select
    
35.     End With
    
36. End Sub

複製代碼

ljuber

感謝各位大大的幫忙  學習了 我還要研究各位的程式碼^^

准提部林

另個參考：
Sub TEST()
Dim xFile, T$, TR, xR As Range, Arr(), Brr, xL$, N&,  i&, j&
xFile = Application.GetOpenFilename("(*.txt), *.txt")
If xFile = "" Then Exit Sub
　
For Each xR In Range([設定!A2], [設定!A1].Cells(Rows.Count, 1).End(xlUp))
　　If xR <> "" Then T = T & "|" & xR
Next
　
Open xFile For Input Access Read As #1
Do Until EOF(1)
　　Line Input #1, xL
　　TR = Split(xL, vbTab)
　　If InStr(T & "|", "|" & TR(4) & "|") Then
　　　　N = N + 1: ReDim Preserve Arr(N - 1): Arr(N - 1) = TR
　　End If
Loop
Close #1
　
If N = 0 Then Exit Sub
ReDim Brr(N - 1, 6)
For i = 0 To N - 1
　　For j = 0 To UBound(Arr(i))
　　　　Brr(i, j) = Arr(i)(j)
　　Next
Next
　
Set xR = [資料!A1].Cells(Rows.Count, 1).End(xlUp)
If xR <> "" Then Set xR = xR(2)
xR.Resize(N, 7) = Brr
End Sub