標題:
請問該如何使用排序並將需要資料帶出至sheet2
[打印本頁]
作者:
yueh0720
時間:
2012-6-8 11:07
標題:
請問該如何使用排序並將需要資料帶出至sheet2
請問該如何使用排序並將需要資料帶出至sheet2
例如:D07-01
D07-02
D07-03
D08-01
D08-02
D08-03
作者:
GBKEE
時間:
2012-6-8 12:51
本帖最後由 GBKEE 於 2012-6-8 16:44 編輯
回復
1#
yueh0720
Option Explicit
Sub Ex()
Dim Ar(), xl As Integer
With Sheets(1) '第1個工作表
.AutoFilterMode = False '取消 這工作表的自動篩選
Ar = .Range("A1").CurrentRegion.Value '資料轉入陣列
.Range("A1").CurrentRegion.Sort Key1:=.Range("H2"), Order1:=xlAscending, Key2:=.Range( _
"A2"), Order2:=xlAscending, Header:=xlYes '排序
.Range("IV:IV") = "" '清除IV欄資料
.Columns("H:H").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IV1"), CriteriaRange:=.Range("IU1:IU2"), Unique:=True
'AdvancedFilter 進階篩選: H欄不重複資料 篩選到.Range("IV1")
xl = 2 '從 第2列 開始
Do While .Range("IV" & xl) <> "" '條件成立: 執行迴圈
If Sheets.Count < xl Then Sheets.Add , Sheets(Sheets.Count) '工作表數小於xl:新增工作表
.Range("A1").AutoFilter Field:=8, Criteria1:=.Range("IV" & xl) '自動篩選: 第8欄=.Range("IV" & xl)
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeConstants).Copy Sheets(xl).[A1] '篩選到的資料:複製到 指定工作表的[A1]
xl = xl + 1 '從第2列: 往下一列
Loop
.AutoFilterMode = False
.Range("A1").CurrentRegion.Value = Ar '取出陣列資料 置回
End With
End Sub
複製代碼
作者:
register313
時間:
2012-6-8 15:13
回復
1#
yueh0720
Sub xx()
Dim Ar(1 To 1000, 1 To 10)
Sheets(1).Select
Br = Array("", "", "Discharge", "charge")
For Sh = 2 To 3
Set d = CreateObject("scripting.dictionary")
[A1].Sort Key1:=[A1], Order1:=xlAscending, Header:=xlGuess
[A1].AutoFilter Field:=8, Criteria1:=Br(Sh)
I = 0
For Each A In Range("A2:A" & [A1].End(xlDown).Row).SpecialCells(xlCellTypeVisible)
If Not d.exists(A.Value) Then
I = I + 1: J = 1
d(A.Value) = A.Offset(0, 1)
Ar(I, J) = A.Offset(0, 17)
Else
J = J + 1
Ar(I, J) = A.Offset(0, 17)
End If
Next
Sheets(Sh).Cells = ""
Sheets(Sh).[A1:M1] = Array("Dock-Ch", "Serial No", "Action", 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Sheets(Sh).[A2].Resize(d.Count, 1) = Application.Transpose(d.keys)
Sheets(Sh).[B2].Resize(d.Count, 1) = Application.Transpose(d.items)
Sheets(Sh).[C2].Resize(d.Count, 1) = Br(Sh)
Sheets(Sh).[D2].Resize(d.Count, 2) = Ar
Set d = Nothing: Erase Ar
Next Sh
Sheets(1).AutoFilterMode = False
End Sub
複製代碼
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)