[發問] excel 自動合併儲存格

星空乂羽翼

請問各位大前輩
小弟我有製作一個專案進度表
想詢問各位如何讓excel自動判斷年/月份來一序合併儲存格呢?
如下圖

下載 (72.31 KB)

2022-11-28 15:57

工作進度表.rar (38.36 KB)

下載次數: 6

2022-11-28 15:53

samwang

回復 1# 星空乂羽翼

請測試看看，謝謝
Sub test()
Dim Arr, xD, C%, T%, T1%
Application.DisplayAlerts = False
Set xD = CreateObject("Scripting.Dictionary")
C = Cells(5, Columns.Count).End(xlToLeft).Column
Arr = Range([e5], Cells(5, C))
For j = 1 To UBound(Arr, 2)
    T = Month(Arr(1, j))
    T1 = Split(Arr(1, j), "/")(2)
    If T1 = 1 Then
        If T = 1 Then
            Cells(4, j + 4) = "一月"
        ElseIf T = 2 Then
            Cells(4, j + 4) = "二月"
        ElseIf T = 3 Then
            Cells(4, j + 4) = "三月"
        ElseIf T = 4 Then
            Cells(4, j + 4) = "四月"
        ElseIf T = 5 Then
            Cells(4, j + 4) = "五月"
        ElseIf T = 6 Then
            Cells(4, j + 4) = "六月"
        ElseIf T = 7 Then
            Cells(4, j + 4) = "七月"
        ElseIf T = 8 Then
            Cells(4, j + 4) = "八月"
        ElseIf T = 9 Then
            Cells(4, j + 4) = "九月"
        ElseIf T = 10 Then
            Cells(4, j + 4) = "十月"
        ElseIf T = 11 Then
            Cells(4, j + 4) = "十一月"
        ElseIf T = 12 Then
            Cells(4, j + 4) = "十二月"
        End If
    End If
    If xD.Exists(T) Then
        Set xD(T) = Union(xD(T), Cells(4, j + 4))
    Else
        Set xD(T) = Cells(4, j + 4)
    End If
Next
For Each ky In xD.keys
    xD(ky).Merge
Next
Application.DisplayAlerts = True
End Sub

samwang

回復 2# samwang

更新一下合併後置中如下，謝謝
For Each ky In xD.keys
    xD(ky).Merge
    xD(ky).HorizontalAlignment = xlCenter   '置中
Next

星空乂羽翼

回復 2# samwang

感謝前輩s大的回覆
我先花點時間理解及測試
後續有問題再跟前輩回報。

星空乂羽翼

回復 3# samwang


好的，謝謝S大！
:D

samwang

回復 4# 星空乂羽翼


處理過程大致如下:
1. 根據第5列資料，在第4列位置會自動填入月份，如一月、二月...
2. 合併同月份，根據第5列資料

星空乂羽翼

回復 6# samwang

S大
目前測試下來，因專案啟始的日期會改變
測試後有一問題
月份合併會出現跨月的情況 (如附圖)

下載 (54.83 KB)
合併超過當前月份

2022-11-29 13:51

下載 (95.56 KB)
合併超過當前月份

2022-11-29 13:51

請問如何改善呢？

另外小弟我沒有VBA的基礎
所以目前會自行上網查閱了解S大您的代碼寫法
想另外請ㄧ個問題
1.若想依條件自動合併儲存格，單純的函數是否無法達成？

以上，再麻煩S大指教，謝謝！

Andy2483

回復 1# 星空乂羽翼


    謝謝前輩發表此主題與範例
謝謝 samwang前輩提供解決方法與解說,後學學習後用相同方法,不同的陳述方式練習陣列與字典
心得註解如下,請各位前輩再指導

Option Explicit
Sub TEST()
Application.DisplayAlerts = False
Dim Brr, C&, x, V, xD, Sh, Tym$, mm&
'↑宣告變數
Set Sh = Sheets("P-012-02A-預定工作進度表")
'↑令Sh 是工作表(以下稱:進度表),名稱是 "P-012-02A-預定工作進度表"
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD 是字典
C = Sh.UsedRange.EntireColumn.Columns.Count
'↑令C 是有使用儲存格範圍的最大欄位數
Brr = Sh.Range(Sh.Cells(5, 1), Sh.Cells(5, C))
'↑令Brr 是二維陣列!倒入從進度表[A5]到第五列最後一欄儲存格範圍儲存格值
For x = 1 To UBound(Brr, 2)
'↑設順迴圈從1到Brr陣列橫向欄位的最大欄位數
   If IsDate(Brr(1, x)) Then
   '↑如果迴圈陣列值是日期??
      Tym = Format(Brr(1, x), "yyyy/mm")
      '↑如果If條件成立!令Tym字串變數 是迴圈陣列值轉化為 四碼年加 "/" 符號加 兩碼月的字串
      If xD.Exists(Tym) = Empty Then
      '↑如果用 Tym字串變數查察字典裡是初始值
         Set xD(Tym) = Sh.Cells(4, x)
         '↑令Tym字串變數是 xD字典裡的key,Item是進度表第4列.迴圈欄的儲存格
         Else
         Set xD(Tym) = Union(xD(Tym), Sh.Cells(4, x))
         '↑令Tym字串變數是 xD字典裡的key,
         'Item是原本Item裡的儲存格再加入 進度表第4列.迴圈欄的儲存格的 儲存格集
      End If
   End If
Next
V = Split(",一,二,三,四,五,六,七,八,九,十,十一,十二", ",")
'↑令V是字串用 ","符號分割的一維陣列
For Each x In xD.Keys
'↑設順迴圈!令x是 xD字典Keys的一員
   xD(x).UnMerge
   '↑xD字典裡迴圈Key對應的 儲存格集取消合併儲存格
   xD(x).Merge
   '↑xD字典裡迴圈Key對應的 儲存格集執行合併儲存格
   xD(x).HorizontalAlignment = xlCenter
   '↑xD字典裡迴圈Key對應的 儲存格集文字左右置中
   mm = Split(x, "/")(1)
   '↑令mm&數字變數是x用 "/"符號拆解的一維陣列!取第 1個字串轉成數字(月份)
   '因為此一維陣列元素是字串,因宣告是mm數字!所以字串會變成數字
   'ps:此一維陣列的第0個字串是(四碼年分)
   xD(x)(1) = V(mm) & "月"
   '↑xD字典裡迴圈Key對應的 儲存格集第一格填入文字:
   '文字是用mm數字抓取 V一維陣列裡對應的國字數字串,後面再加 "月"字
Next
Set Brr = Nothing
Set xD = Nothing
End Sub

samwang

回復  samwang

S大
目前測試下來，因專案啟始的日期會改變
測試後有一問題
月份合併會出現跨月的情況 ...
星空乂羽翼 發表於 2022-11-29 13:52

請提供有問題檔案，這樣比較容易測試，謝謝

若想依條件自動合併儲存格，單純的函數是否無法達成？這後學不知道，可以再看看其他大大

星空乂羽翼

回復 9# samwang

S大
以下為有問題的檔案
工作進度表-測試巨集.rar (47.88 KB)

下載次數: 3

2022-11-29 14:52

   
另外
日期的產生是
除了起始日期(第一天)是手動填入以外
其餘是用+1的方式來判斷後續日期。
再麻煩S大除錯了，感謝。