請問該如何使用排序並將需要資料帶出至sheet2

yueh0720

請問該如何使用排序並將需要資料帶出至sheet2
例如：D07-01
        D07-02
        D07-03
        D08-01
        D08-02
        D08-03

GBKEE

回復 1# yueh0720

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Ar(), xl As Integer
   
4.     With Sheets(1)                              '第1個工作表
   
5.         .AutoFilterMode = False                 '取消 這工作表的自動篩選
   
6.         Ar = .Range("A1").CurrentRegion.Value   '資料轉入陣列
   
7.          .Range("A1").CurrentRegion.Sort Key1:=.Range("H2"), Order1:=xlAscending, Key2:=.Range( _
   
8.             "A2"), Order2:=xlAscending, Header:=xlYes                     '排序
   
9.          .Range("IV:IV") = ""                   '清除IV欄資料
   
10.          .Columns("H:H").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IV1"), CriteriaRange:=.Range("IU1:IU2"), Unique:=True
    
11.                                                 'AdvancedFilter 進階篩選: H欄不重複資料  篩選到.Range("IV1")
    
12.         xl = 2                                  '從 第2列 開始
    
13.         Do While .Range("IV" & xl) <> ""        '條件成立: 執行迴圈
    
14.             If Sheets.Count < xl Then Sheets.Add , Sheets(Sheets.Count)  '工作表數小於xl:新增工作表
    
15.             .Range("A1").AutoFilter Field:=8, Criteria1:=.Range("IV" & xl)      '自動篩選: 第8欄=.Range("IV" & xl)
    
16.             .Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants).Copy Sheets(xl).[A1] '篩選到的資料:複製到 指定工作表的[A1]
    
17.             xl = xl + 1                         '從第2列: 往下一列
    
18.         Loop
    
19.         .AutoFilterMode = False
    
20.          .Range("A1").CurrentRegion.Value = Ar  '取出陣列資料 置回
    
21.     End With
    
22. End Sub

複製代碼

register313

回復 1# yueh0720

1. Sub xx()
   
2. Dim Ar(1 To 1000, 1 To 10)
   
3. Sheets(1).Select
   
4. Br = Array("", "", "Discharge", "charge")
   
5. For Sh = 2 To 3
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   [A1].Sort Key1:=[A1], Order1:=xlAscending, Header:=xlGuess
   
8.   [A1].AutoFilter Field:=8, Criteria1:=Br(Sh)
   
9.   I = 0
   
10.   For Each A In Range("A2:A" & [A1].End(xlDown).Row).SpecialCells(xlCellTypeVisible)
    
11.     If Not d.exists(A.Value) Then
    
12.        I = I + 1: J = 1
    
13.        d(A.Value) = A.Offset(0, 1)
    
14.        Ar(I, J) = A.Offset(0, 17)
    
15.     Else
    
16.        J = J + 1
    
17.        Ar(I, J) = A.Offset(0, 17)
    
18.     End If
    
19.   Next
    
20. Sheets(Sh).Cells = ""
    
21. Sheets(Sh).[A1:M1] = Array("Dock-Ch", "Serial No", "Action", 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
    
22. Sheets(Sh).[A2].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
23. Sheets(Sh).[B2].Resize(d.Count, 1) = Application.Transpose(d.items)
    
24. Sheets(Sh).[C2].Resize(d.Count, 1) = Br(Sh)
    
25. Sheets(Sh).[D2].Resize(d.Count, 2) = Ar
    
26. Set d = Nothing: Erase Ar
    
27. Next Sh
    
28. Sheets(1).AutoFilterMode = False
    
29. End Sub

複製代碼