Board logo

標題: [發問] excel 自動篩選依照另外一個工作表的內容 [打印本頁]
作者: ljuber    時間: 2016-1-21 11:17     標題: excel 自動篩選依照另外一個工作表的內容

本帖最後由 ljuber 於 2016-1-21 11:18 編輯

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

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

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

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

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

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

(附上檔案）[attach]23150[/attach]

錄製的巨集：
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    時間: 2016-1-22 00:42

回復 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
複製代碼
運行附件[attach]23157[/attach]中的按鈕：
作者: c_c_lai    時間: 2016-1-22 08:31

回復 1# ljuber
試試看：
  1. Option Explicit

  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    時間: 2016-1-22 08:52

感謝各位大大的幫忙  學習了 我還要研究各位的程式碼^^
作者: 准提部林    時間: 2016-1-23 18:14

另個參考：
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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)