返回列表下一主題上一主題發帖

[發問] 自動整理資料

adam2010

中學生 Rank: 2

帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2014-1-19 00:30 | 只看該作者

[發問] 自動整理資料

各位高手協助，我在每日排程之後需要將排好的資料依據機台別放入匯總表內
請問要從橘色區塊整理到匯總工作表的巨集要如何製作
因為機台號碼與機台數都會變動，每個站點機台數最多5台
目前都是排好後手動複製轉值到總表→排序→刪除空格，
因為其實站點不只4個所以排好之後還需要浪費蠻多時間整理的

整理問題.zip (66.17 KB)

樓主熱帖

Adam

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

2^#

發表於 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元的贊助,人人有能力.

TOP

adam2010

中學生 Rank: 2

帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

3^#

發表於 2014-1-19 13:12 | 只看該作者

感謝GBKEE的協助，第一次看到使用 Option Explicit，查了一下是在模組層次中使用，強制模組中的所有變數必須明確地宣告，看不太懂但是測試OK!
真是太強了，所以我只要確保每個站點工作表的機台資料都從U1開始，不管幾站只要不叫彙總，
就都可以整理進彙總裡面去囉~
真是太感謝了！

Adam

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

4^#

發表於 2014-1-19 16:12 | 只看該作者

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

回復 3# adam2010

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

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

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

5^#

發表於 2023-4-21 11:17 | 只看該作者

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與排序,學習方案如下,請各位前輩指教

執行結果:

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Brr, Crr, Y, Z, R&, C&, i&, j&, T$
Dim xR As Range, Sh As Worksheet
ReDim Crr(1 To 1000, 1 To Columns.Count - 1)
For Each Sh In Sheets
If InStr(Sh.Name, "站") = 1 Then
   Set xR = Intersect(Sh.UsedRange, Sh.[U:Y]): Brr = xR
   For C = 1 To UBound(Brr, 2)
      If Brr(1, C) = "" Then GoTo i01 Else: j = j + 1: i = 0
      For R = 1 To UBound(Brr)
         T = Brr(R, C)
         If R = 1 Then T = Left(T, 3) & Format(Mid(T, 4), "00")
         If T <> "" Then i = i + 1: Crr(i, j) = T
      Next
      If i > Z Then Z = i
i01:  Next
End If
Next
With Sheets("彙總").[A1].Resize(Z, j)
.CurrentRegion.Clear
.Value = Crr
.Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=2
For C = 1 To j
   Intersect(.Cells, .Item(C).EntireColumn).Sort _
   Key1:=.Item(C), Order1:=1, Header:=1, Orientation:=1
Next
End With
Set Sh = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

靜思自在 : 【生命在呼吸間】佛陀說：「生命在呼吸間。」人無法管住自己的生命，更無法擋住死期，讓自己永住人間。既然生命去來這麼無常，我們更應該好好地愛惜它、利用它、充實它，讓這無常、寶貴的生命，散發它真善美的光輝，映照出生命真正的價值。

返回列表下一主題上一主題