[發問] 自動整理資料

adam2010

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

下載 (185.57 KB)

2014-1-19 00:26

下載 (162.09 KB)

2014-1-19 00:26

整理問題.zip (66.17 KB)

下載次數: 11

2014-1-19 00:26

GBKEE

回復 1# adam2010
試試看

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

複製代碼

adam2010

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

GBKEE

回復 3# adam2010

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

Andy2483

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

執行結果:

下載 (178.87 KB)

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