返回列表 上一主題 發帖

[發問] MARCO公式合併儲存格.和用顏色:黃色 分開不相同

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
1# 跳轉到 »
發表於 2019-3-6 19:32 | 顯示全部帖子
Sub TEST()
Dim xR As Range, CL, U%, xH As Range, SS
Call 重置
CL = Array(35, 36)
For Each xR In Range([C2], Cells(Rows.Count, "c").End(xlUp))
    If xR <> xR(0) Then Set xH = xR: SS = 0
    SS = SS + Val(xR(1, 3))
    If xR <> xR(2) Then
       xH(1, 4) = SS: U = 1 - U
       Range(xR, xH(1, 8)).Interior.ColorIndex = CL(U)
       Range(xH(1, 4), xR(1, 4)).Merge
    End If
Next
End Sub
  
Sub 重置()
With Range([J2], Cells(Rows.Count, "c").End(xlUp))
     .UnMerge
     .Interior.ColorIndex = 0
     .Columns(4).ClearContents
End With
End Sub

Xl0000239.rar (12.6 KB)

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
2#
發表於 2019-3-9 09:55 | 顯示全部帖子
回復 6# john2006168

Sub TEST()
Dim xR As Range, CL, U%, xH As Range, SS
Call 重置
CL = Array(35, 36)
For Each xR In Range("D2:D" & Cells(Rows.Count, "k").End(xlUp).Row)  '以k欄取資料列數, xR則從D2往下迴圈
    If xR(1, 8) <> xR(0, 8) Then Set xH = xR: SS = 0    'xR(1,8) D欄往右8格, 即是K欄; xR(1, 8) <> xR(0, 8) 1是本格,0是上一格,2是下一格 ---以下程式碼同理
    SS = SS + Val(xR(1, 2))
    If xR(1, 8) <> xR(2, 8) Then
       xH(1, 3) = SS: U = 1 - U
       Range(xR(1, 8), xH).Interior.ColorIndex = CL(U)
       Range(xH(1, 3), xR(1, 3)).Merge
    End If
Next
End Sub
  
Sub 重置()
With Range([D2], Cells(Rows.Count, "k").End(xlUp))
     .UnMerge
     .Interior.ColorIndex = 0
     .Columns(3).ClearContents
End With
End Sub

TOP

        靜思自在 : 布施如播種，以歡喜心滋潤種子，才會發芽。
返回列表 上一主題