Board logo

標題: 請問:excel快速合併儲存格 [打印本頁]
作者: jessicamsu    時間: 2012-9-7 21:55     標題: 請問:excel快速合併儲存格

請問,如何將附件左邊的資料可以快速合併成右手邊的資料,謝謝
作者: chin15    時間: 2012-9-7 22:47

用樞紐分析表
[attach]12404[/attach]
作者: jessicamsu    時間: 2012-9-8 10:12

樓上的大大先謝謝,但我因為要貼在另一個sheet並與其他資料彙整,所以樞紐並不適合,謝謝
作者: Hsieh    時間: 2012-9-8 10:35

回復 3# jessicamsu
先用樞紐做出你的格式，再複製貼上就可以
作者: chin15    時間: 2012-9-8 10:43

應該是想練習循環吧？參考
  1. Sub test()
  2.     Dim c%, n%, i%, r%
  3.     Application.DisplayAlerts = False
  4.     n = [a65536].End(xlUp).Row
  5.     For c = 1 To 2
  6.         r = 2
  7.         For i = 2 To n
  8.             If Cells(i, c) <> Cells(i + 1, c) Then
  9.                 If r < i Then Range(Cells(r, c), Cells(i, c)).Merge
  10.                 r = i + 1
  11.             End If
  12.         Next
  13.     Next
  14. End Sub
複製代碼
作者: jessicamsu    時間: 2012-9-8 18:35

謝謝chin15 大大,但經測試後,C欄沒有合併耶,不好意思,再麻煩您幫忙一下
作者: jessicamsu    時間: 2012-9-8 18:42

回復 5# chin15

謝謝chin15 大大,但經測試後,C欄沒有合併耶

將C改為c = 1 To 3, 但C欄黃色部份會有問題,正確應該要像右手邊一樣@@
[attach]12415[/attach]
作者: chin15    時間: 2012-9-8 21:23

c欄不能納入循環中操作
  1. Sub test()
  2.     Dim c%, n%, i%, r%
  3.     Application.DisplayAlerts = False
  4.     n = [a65536].End(xlUp).Row
  5.     For c = 1 To 2
  6.         r = 2
  7.         For i = 2 To n
  8.             If Cells(i, c) <> Cells(i + 1, c) Then
  9.                 If r < i Then Range(Cells(r, c), Cells(i, c)).Merge
  10.                 r = i + 1
  11.             End If
  12.         Next
  13.     Next
  14.     For r = 2 To n
  15.         If Cells(r, 2).MergeCells Then
  16.             a = Cells(r, 2).MergeArea.Address
  17.             s = Split(a, "$")
  18.             For k = Val(s(2)) To Val(s(4))
  19.                 Do While Cells(k, 3).Offset(j, 0) = Cells(k, 3) And k + j <= Val(s(4))
  20.                     j = j + 1
  21.                 Loop
  22.                 If j > 1 Then
  23.                     Cells(k, 3).Resize(j).Merge
  24.                     k = k + j - 1
  25.                     j = 1
  26.                 End If
  27.             Next
  28.             r = k - 1
  29.         End If
  30.     Next
  31. End Sub
複製代碼
作者: Hsieh    時間: 2012-9-9 00:11

回復 7# jessicamsu
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. Application.DisplayAlerts = False
  4. For i = 3 To 1 Step -1
  5.    For Each a In Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
  6.    mystr = a & a.Offset(, IIf(i = 1, 0, -1))
  7.       If IsEmpty(d(mystr)) Then
  8.          Set d(mystr) = a
  9.          Else
  10.          Set d(mystr) = Union(d(mystr), a)
  11.       End If
  12.     Next
  13.     For Each ky In d.keys
  14.     d(ky).Merge
  15.     Next
  16.     d.RemoveAll
  17. Next
  18. Application.DisplayAlerts = True
  19. End Sub
複製代碼
作者: c_c_lai    時間: 2012-9-9 10:36

回復 7# jessicamsu
Hsieh 前輩的 Idea 非常棒，我將它稍稍修飾了一下，
即先將 A2:C28 的內容複製到 E2:G28 後再處理分析，
以明確看得出來程式是如何執行處理的。
同時補上了 ky 的變數宣告。
  1. Sub ex()
  2.     Dim ky As Variant
  3.    
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.     Application.DisplayAlerts = False
  6.    
  7.     [A2:C28].Copy Destination:=[E2]
  8.    
  9.     For i = 7 To 5 Step -1
  10.         For Each a In Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp))
  11.             mystr = a & a.Offset(, IIf(i = 5, 0, -1))
  12.             If IsEmpty(d(mystr)) Then
  13.                 Set d(mystr) = a
  14.             Else
  15.                 Set d(mystr) = Union(d(mystr), a)
  16.             End If
  17.         Next
  18.         For Each ky In d.keys
  19.             d(ky).Merge
  20.         Next
  21.         d.RemoveAll
  22.     Next
  23.    
  24.     Application.DisplayAlerts = True
  25. End Sub
複製代碼
[attach]12421[/attach]



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