求論壇大神幫我看看這個表格，需求A到I列有相同的合并。T到U列有相同的合并，具體麻煩看下附件。感謝。只差最后的一點了，感謝。現在測驗了一下。第9行，第10行合并不了。其他都可以
(原表）
（希望得到的）
（代碼）
uj5u.com熱心網友回復：
感謝，感謝。第一次來uj5u.com熱心網友回復：
在Excel 2003中開始記錄宏，手動完成所需功能，結束記錄宏，按Alt+F11鍵，查看剛才記錄的宏對應的VBA代碼。uj5u.com熱心網友回復：
這么久還沒解決嗎？想知道怎么解決就回復一下，否則別人說了也是浪費感情。
uj5u.com熱心網友回復：
跟蹤除錯一下，看是否處理到第 10 行。uj5u.com熱心網友回復：
估計已成墳。
uj5u.com熱心網友回復：
千年等挖墳。
uj5u.com熱心網友回復：
Public Function exceldc(ByVal tt As String)Dim t As Integer
Dim B As Integer
B = 1
Set xlsApp = CreateObject("Excel.Application")
Set xlswb = xlsApp.Workbooks.Open(tt) '要打開的檔案路徑
Set xlsws = xlswb.Worksheets(1)
xlsApp.DisplayAlerts = False
Set Worksheet = xlsApp.ActiveSheet
'獲取資料
'xlsWs.Range(Cells(1, 2), Cells(1, 5)).Merge '合并a1:b2單元格
For ff = 1 To xlsws.UsedRange.Columns.Count
If xlsws.Cells(1, ff) = xlsws.Cells(1, ff + 1) Then
t = t + 1
Else
If t > 0 Then
xlsws.Range(xlsws.Cells(1, ff - t), xlsws.Cells(1, ff)).Merge '合并a1:b2單元格
t = 0
End If
End If
If xlsws.Cells(1, ff) = xlsws.Cells(2, ff) Then
xlsws.Range(xlsws.Cells(1, ff), xlsws.Cells(2, ff)).Merge '合并a1:b2單元格
End If
Next ff
xlswb.Save
xlswb.Close
xlsApp.Quit
Set xlsws = Nothing
Set xlswb = Nothing
Set xlsApp = Nothing
Shell "cmd.exe /c start " & tt, vbMaximizedFocusL
End Function
這段代表我用來合并表頭的。相同 合并，你自己拿去改改！
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/69946.html
標籤：VBA
上一篇：安裝程式求助