v03586

回復 7# GBKEE


    感謝板大的協助
  第九行這一段

1. If UBound(sp) >= 2 Then

複製代碼

改成這一段就可以完成了 !!! 再次感謝~~

v03586

回復  v03586
Hsieh 發表於 2017-8-2 14:53

    感謝板大的提供另一種方式, 對於畫線的方式, 又學到一招板大的方式撰寫

v03586

回復 8# Kubi


    感謝大大的提供 !!

准提部林

Sub test()
Dim xR As Range, xH As Range
For Each xR In [H2:H19]
　　If xH Is Nothing Then xR = Split(Replace(xR, "-", "+", , 2), "+")(2): Set xH = xR
　　If xR(2) <> "" Then xR(2) = Split(Replace(xR(2), "-", "+", , 2), "+")(2)
　　If xR(2) <> xR Then
　　　　With Range(xR, xH)
　　　　　　　.Borders.Weight = 3
　　　　　　　If .Count > 1 Then .Borders(12).Weight = 2
　　　　End With
　　　　Set xH = xR(2)
　　End If
Next
End Sub
　
　

v03586

回復 14# 准提部林

請問一下, 我有依照我的額外需求做了一些小修改, 想請問一下
如果我要判斷畫線的資料欄位在D欄位 ,  我如何修改讓他算整筆資料的最後一欄 ??
是加入下面這一段嗎???

1. .Range("D65536").End(xlUp).Row To 2 Step -1

複製代碼

再來我要畫線的範圍是A2欄到AD2欄

1. Dim xR As Range, xH As Range
   
2. For Each xR In [D2:D3000]
   
3.     If xH Is Nothing Then Set xH = xR
   
4.     If xR(2) <> xR Then
   
5.         With Range(xR, xH)
   
6.               .Borders.Weight = 4
   
7.               If .Count > 1 Then .Borders(12).Weight = 2
   
8.         End With
   
9.         Set xH = xR(2)
   
10.     End If
    
11. Next

複製代碼

准提部林

回復 15# v03586


For Each xR In Range([D2], [D65536].End(xlUp))
　　If xR.Row < 2 Then Exit Sub '當D2以下為空時,結束程序
　　或　If xR.Row < 2 Then Exit For '當D2以下為空時,跳出迴圈
　
Next

v03586

回復 16# 准提部林

請問一下大大, 修改後判斷式為D欄位只要有一樣的話細線, 不一樣的畫粗線來做分別
但是我的判斷一樣使用D欄位, 但話線的範圍要擴大A2欄位到AD2以下的欄位都要話線 , 請問要如何延伸呢?
判斷式一樣是由D欄位

1. Dim xxR As Range, xxH As Range
   
2. For Each xxR In Range([D2], [D65536].End(xlUp))
   
3.     If xxR.Row < 2 Then Exit Sub
   
4.     If xxH Is Nothing Then Set xxH = xxR
   
5.     If xxR(2) <> xxR Then
   
6.         With Range(xxR, xxH)
   
7.               .Borders.Weight = 4
   
8.               If .Count > 1 Then .Borders(12).Weight = 2
   
9.         End With
   
10.         Set xxH = xxR(2)
    
11.     End If
    
12. Next

複製代碼

下載 (55.43 KB)

2017-8-6 15:43

准提部林

回復 17# v03586


有合併格？？？
上傳檔案再看看！！！
　

v03586

回復 18# 准提部林


    抱歉, 沒有合併格, 合併格是我處理完畫線才合併格的 !!!


TEST2.rar (65.2 KB)

下載次數: 1

2017-8-6 17:44

准提部林

回復 19# v03586


Sub test()
Dim R, xR As Range, xH As Range, xE As Range, i&, V&
R = [D65536].End(xlUp).Row
For i = 2 To R
　　Set xR = Cells(i, "D")
　　If xH Is Nothing Then Set xH = Cells(i, "AD")
　　V = xR.MergeArea.Rows.Count
　　Set xE = xR(V)
　　If xR <> xE(2) Then
　　　　With Range(Cells(xE.Row, 1), xH)
　　　　　　　.Borders.Weight = 4
　　　　　　　If .Columns.Count > 1 Then .Borders(11).Weight = 2
　　　　　　　If .Rows.Count > 1 Then .Borders(12).Weight = 2
　　　　End With
　　　　Set xH = Cells(i + V, "AD")
　　End If
　　i = i + V - 1
Next i
End Sub

不管Ｄ欄有沒有合併格，都可以！！