合并指定列的相邻单元格中相同的元素
option Explicit
Dim objExcel
Dim objWorkbook
Dim temp
GPTScript
Sub GPTScript
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("E:\1.xls")
objExcel.Visible = True
Call CombineSameValue(3, 33) '测试第三列,共33行
End Sub
'可能存在合并的单元格,所以首先要判断是否是合并的单元格
Function GetCellValue(rowNum, columnNum)
Dim mergePar
Dim columnName
columnName = GetColumnName(columnNum)
Set mergePar = objExcel.Range(columnName&CStr(rowNum)).MergeArea
If objExcel.Range(columnName&CStr(rowNum)).MergeCells Then
GetCellValue = mergePar.Cells(1, 1).Value
Else
GetCellValue = objExcel.Cells(rowNum, columnNum).Value
End If
End Function
'合并相邻并且值相同的单元格 行和列都是从1开始
Sub CombineSameValue(columnNum, endRowNum)
Dim currentValue
Dim nextValue
Dim columnName
Dim currenRowNum
Dim nextRowNum
Dim k
columnName = GetColumnName(columnNum)
objExcel.DisplayAlerts = false
Dim startPos
Dim endPos
startPos = 1 : endPos = 1
For k=1 To endRowNum-1
currentValue = GetCellValue(k, columnNum)
nextValue = GetCellValue(k+1, columnNum) 'objExcel.Cells(k+1, columnNum).Value
If currentValue<>"" And currentValue=nextValue Then
endPos = k+1
Else
currenRowNum = CStr(startPos)
nextRowNum = CStr(endPos)
If currenRowNum <> nextRowNum Then
objExcel.Range(columnName¤RowNum&":"&columnName&nextRowNum).Merge()
End If
startPos = k+1
endPos = k+1
End If
Next
objExcel.DisplayAlerts = true
End Sub
'列从1开始 1(A) 2(B) 27(AA) 28(AB) 在2003下excel最大列是IV,所以最多两位数就可以了
Function GetColumnName(columnNum)
Dim num
num = columnNum - 1
If num < 26 Then
GetColumnName = Chr(Asc("A") + num)
Else
GetColumnName = Chr(Asc("A")+(num\26)- 1)&Chr(Asc("A")+(num Mod 26))
End If
End Function
请注明文章出处:http://www.cnblogs.com/zhfuliang