彰化一整天的論壇

 找回密碼
 立即註冊
查看: 3421|回復: 0

在Excel中快速合併相同資料並跨欄置中

[複製鏈接]
發表於 2014-5-1 11:29:20 | 顯示全部樓層 |閱讀模式
本帖最後由 imingho 於 2020-2-28 18:56 編輯

很多人在處理Excel資料時,會將相同的資料用合併儲存格的方式合併,但是Excel一次只可以合併一個,沒辦法自動判斷將相同的資料合併成一個儲存格,因此寫了這一支程式來處理這種情形,可以設定要合併欄位或是將相同欄位的資料只變成第一筆顯示,後面相同的都變成空白。
merger_field_01.jpg
1.不合併變成空白的結果
merger_field_02.jpg
2.儲存格B2選[是]
merger_field_03.jpg
3.合併欄位
merger_field_04.jpg
4.儲存格B2選[否]
  1. Private Sub cmdClear_Click()
  2.     Sheet2.Cells.Clear
  3. End Sub

  4. Public Sub cmdCompareab_Click()
  5.     Dim n As Integer '欄位數
  6.     Dim count_a As Double  '資料ab的筆數
  7.     Dim temp As String
  8.     Dim my_range
  9.    
  10.    
  11.     Sheet2.Activate
  12.     count_a = Sheet2.Range("a1").End(xlDown).Row
  13.     n = Sheet2.Range("a1").End(xlToRight).Column


  14.     Sheet1.Activate
  15.     MergerField = Sheet1.Range("b1")  '合併第m個欄位
  16.    
  17.     MergerFields = Split(MergerField, ",")



  18.     Sheet2.Activate
  19.    
  20.     Sheet2.Cells.Copy
  21.    
  22.     Sheet3.Activate
  23.    
  24.     Sheet3.Cells(1, 1).Select
  25.    
  26.     ActiveSheet.Paste

  27.    
  28.     Sheet1.Activate

  29.    
  30.    
  31.    
  32.     mergerStart = 1

  33.     For k = 0 To UBound(MergerFields)

  34.         For i = 2 To count_a + 1
  35.             
  36.    
  37.             If Sheet3.Range(MergerFields(k) & i) <> Sheet3.Range(MergerFields(k) & i - 1) Then
  38.    
  39.                 mergerEnd = i - 1

  40.                 'Debug.Print mergerStart
  41.                 'Debug.Print mergerEnd
  42.                 '合併儲存格
  43.                 Sheet3.Activate
  44.                 '清除第二筆資料
  45.                 If Count > 0 Then '判斷有二筆以上才處理

  46.                     Sheet3.Range(MergerFields(k) & mergerStart + 1 & ":" & MergerFields(k) & mergerEnd).Clear
  47.                     Sheet3.Range(MergerFields(k) & mergerStart & ":" & MergerFields(k) & mergerEnd).Select
  48.                     If Sheet1.Range("b2") <> "是" Then
  49.                         With Selection
  50.                             .HorizontalAlignment = xlCenter
  51.                             .VerticalAlignment = xlCenter
  52.                             .WrapText = False
  53.                             .Orientation = 0
  54.                             .AddIndent = False
  55.                             .IndentLevel = 0
  56.                             .ShrinkToFit = False
  57.                             .ReadingOrder = xlContext
  58.                             .MergeCells = False
  59.                         End With
  60.                         Selection.Merge
  61.                     End If
  62.                     Count = 0
  63.                 End If

  64.             Else
  65.                 Count = Count + 1
  66.                 If Count = 1 Then
  67.                     mergerStart = i - 1
  68.                 End If
  69.    
  70.    
  71.                
  72.             End If
  73.             
  74.    
  75.    
  76.    
  77.             DoEvents
  78.             

  79.         Next
  80.     Next
  81.    
  82.     MsgBox "處理完畢!!", vbOKOnly, "彰化一整天的blog(http://blog.bestdaylong.com/)"
  83.    
  84. End Sub

複製代碼


mergerfield.xls

69 KB, 下載次數: 5

售價: 2 金錢  [記錄]

mergerfield.xls

回復

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)

GMT+8, 2021-2-25 04:30 , Processed in 0.127739 second(s), 20 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回復 返回頂部 返回列表