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¤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