Board logo

標題: [發問] 自動整理資料 [打印本頁]
作者: adam2010    時間: 2014-1-19 00:30     標題: 自動整理資料

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

回復 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    時間: 2014-1-19 13:12

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

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

回復 3# adam2010

我完整的程式碼大都會加上   Option Explicit 不懂看看這裡
作者: Andy2483    時間: 2023-4-21 11:17

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

執行結果:
[attach]36200[/attach]


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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)