自動整理資料 - Excel程式區 - 麻辣家族討論版版

[發問] 自動整理資料

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2014-1-19 07:53 | 顯示全部帖子

回復 1# adam2010
試試看

Option Explicit
Sub Ex()
Dim D As Object, Sh As Worksheet, Rng As Range, i As Integer, AR As Variant
Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
For Each Sh In Sheets '工作表物件集合
If Not Sh.Name Like "彙總*" Then '比對工作表名稱
Set Rng = Sh.[U1] '機台固定從[U1]開始
Do While Rng <> ""
For i = 2 To Sh.[A1].End(xlDown).Row '[A1]往下到最後連續的資料列號
If Rng.Cells(i, 1).Value <> "" Then
If Not D.EXISTS(Rng.Value) Then 'EXISTS: 傳回字典物件(key[關鍵字])存在=True
D(Rng.Value) = Array(Rng.Cells(i, 1).Value) '字典物件(key).Item=>內容,置入陣列
Else
AR = D(Rng.Value) '陣列取得字典物件(key).Item
ReDim Preserve AR(UBound(AR) + 1) '陣列擴充增加一元素)
AR(UBound(AR)) = Rng.Cells(i, 1).Value '陣列(UBound(AR))元素的上限值
D(Rng.Value) = AR '字典物件(key[關鍵字])=陣列
End If
End If
Next
Set Rng = Rng.Offset(, 1) '向右移動
Loop
End If
Next
With Sheets("彙總")
.UsedRange.Clear
i = 1
For Each AR In D.KEYS '字典物件(key)
.Cells(1, i) = AR
.Cells(2, i).Resize(UBound(D(AR)) + 1) = Application.WorksheetFunction.Transpose(D(AR)) '一維陣列轉成二維陣列
i = i + 1
Next
.UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, Orientation:=xlLeftToRight '排序循列(橫向)
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2014-1-19 16:12 | 顯示全部帖子

本帖最後由 GBKEE 於 2014-1-19 16:15 編輯

回復 3# adam2010

我完整的程式碼大都會加上 Option Explicit 不懂看看這裡

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 成功是優點的發揮，失敗是缺點的累積。