[µo°Ý] excel ¦Û°Ê¿z¿ï¨Ì·Ó¥t¥~¤@­Ó¤u§@ªíªº¤º®e ¿z¿ï, VBA

ljuber

½Ð°Ý¦U¦ì¤j¤j §Ú¦³­Ó¸g±`©Êªº¤u§@

§Ú¦³¿ý»s¥¨¶°¨Ã¥B¤p¤p­×§ï ¦ý¬O¦³¤U­±´X¶µ¤£ª¾¹D­n«ç»ò­×§ï¡G

1.¥i¥H±qÀÉ®×Á`ºÞ¿ï¾Ü¤å¦rÀɮ׶פJ

2.¿z¿ï±ø¥ó¦b ³]©w¤u§@ªíªºA2:A4 (¦¹½d³ò·|ÅÜ°Ê)
  (¬O¨Ì·Ótab¤À¹j ·|¦b²Ä¤­Äæ)

3.½Æ»s§¹«á¤å¦rÀÉ®×·|¦Û°ÊÃö³¬

4.§â¿z¿ï«áªº¸ê®Æ¶K¨ì¸ê®Æ¤u§@ªí¡A¸ê®Æ·|¤@ª½©¹¤U¥[¤U¥h

(ªþ¤WÀɮס^ ½m²ß.zip (346.84 KB)

¤U¸ü¦¸¼Æ: 12

2016-1-21 11:17

¿ý»sªº¥¨¶°¡G
Sub Macro1()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set MainSh = Workbooks("½m²ß.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

½Æ»s¥N½X

¹B¦æªþ¥ó ½m²ß.zip (350.79 KB)

¤U¸ü¦¸¼Æ: 5

2016-1-22 00:40

¤¤ªº«ö¶s¡G

c_c_lai

¦^´_ 1# ljuber
¸Õ¸Õ¬Ý¡G

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("½m²ß.xlsm")
    
14.         cts = .Sheets("³]©w").Range("A1").End(xlDown).Row
    
15.         
    
16.         ReDim Preserve arr(cts - 1)       '  °ÊºA¦a³B²z arr °}¦C±a¤J¤§°}¦C­È¡C
    
17.         For loc = 2 To cts
    
18.            arr(loc - 1) = .Sheets("³]©w").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.             '  °ÊºA¦a³B²z Criteria1 ±a¤J¤§­È¡C
    
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

½Æ»s¥N½X

ljuber

·PÁ¦U¦ì¤j¤jªºÀ°¦£  ¾Ç²ß¤F §ÚÁÙ­n¬ã¨s¦U¦ìªºµ{¦¡½X^^

­ã´£³¡ªL

¥t­Ó°Ñ¦Ò¡G
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([³]©w!A2], [³]©w!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