VBScript Excle列中相同元素进行合并

合并指定列的相邻单元格中相同的元素

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&currenRowNum&":"&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