【Excel VBA】- 為表格中一行內容添加刪除線

女神節當天，在牛閃閃的日子1群中，有位河南的朋友諮詢了一個看似簡單的問題，詳情請看下圖：

看到此問題，第一反應就是設置單元格字體格式，從而增加刪除線，具體操作請見如下動態圖。

如上動態圖中，第一次選中第8行，然後設置單元格格式→字體→刪除線。隨後選中的12、15和16行，都是按下鍵盤上的快捷鍵F4重複上一操作完成的。

從問題截圖來看，這位河南朋友想要的結果不是上圖中的效果，而是希望刪除線連成線。找了許久，沒有發現Excel有此功能，所以只能想一個變通的方法，配合形狀中的線條來完成。最終達到的效果如下：

如上動態圖中是為了方便查看才設置了一個按鈕，為了更加方便可以為編寫的宏設置快捷鍵，按下鍵盤上快捷鍵即可快速設置「刪除線」。

可以看到，為宏test設置快捷鍵為Ctrl+Shift+R，即可快速設置刪除線，而不需要點擊按鈕。

好，接下來就是見證奇蹟代碼的時刻^_^

Sub test()

Dim calcHeight1, calcHeight2 As LongPtr

Dim calcWidth1, calcWidth2 As LongPtr

row1 = Range(Selection.Address).Row

row2 = Range(Selection.Address).Rows.Count + row1 - 1

col1 = Range(Selection.Address).Column

col2 = Range(Selection.Address).Columns.Count + col1 - 1

calcHeight1 = 0

calcHeight2 = 0

For i = 1 To row1 - 1

calcHeight1 = calcHeight1 + Cells(i, 1).Height

Next

For i = row1 To row2

calcHeight2 = calcHeight2 + Cells(i, 1).Height

Next

calcHeight2 = calcHeight1 + calcHeight2

calcWidth1 = 0

calcWidth2 = 0

For i = 1 To col1 - 1

calcWidth1 = calcWidth1 + Cells(1, i).Width

Next

For i = col1 To col2

calcWidth2 = calcWidth2 + Cells(1, i).Width

Next

calcWidth2 = calcWidth1 + calcWidth2

下面的代碼不要問我怎麼記住的，我是錄製宏後加以修改的^_^

ActiveSheet.Shapes.AddConnector(msoConnectorStraight, calcWidth1, (calcHeight1 + calcHeight2) / 2, calcWidth2, (calcHeight1 + calcHeight2) / 2).Select

With Selection.ShapeRange.Line

.Visible = msoTrue

.ForeColor.ObjectThemeColor = msoThemeColorText1

.Weight = 1.5

End With

End Sub

各位小夥伴如果有更好的辦法解決此問題，歡迎交流學習~~Written by Steven in 20170309^_^

微信公眾號：SaveUTime

SUT學習交流群：615356012，入群審核人：Steven

關注公眾號，提高效率，節約您的時間！