导航↓ 相册|收藏博客|加入友情链接|给博主留言
畅享博客 > Bill 的博客--专注IT技术及管理 > 微软-其他知识 > [原创]Excel 宏vba 自动合并单元列
2011/11/16 14:25:54

[原创]Excel 宏vba 自动合并单元列

需求:

根据列合并; 同一列中相邻内容一致的合并成一个单元格, 以变美观

 

分析:

在需要合并的sheet中, 加入一个按钮, 点击此按钮

出现提示框, 让用户自己输入需要合并的列; 列名可以为数字或字母; 如输入1, 代表第一列; 输入A, 也代表第一列

自动判断所有的行数;

进行循环遍历; 将此列内容相同的相邻2列或几列, 合并单元格

难点:

合并单元格总出现提示框, 警告将丢失部分信息; 解决办法application.displayallert=false; 取消警告框;遍历完毕后, 再恢复displayalert=true

源代码:

Sub MergeCol()
    Dim iCol As Integer
   
    Dim strCol    As String
    strCol = InputBox("Please Input the column you want to merge")
    strCol = Trim(strCol)
    Dim strColName As String
    If strCol = "" Then
        Exit Sub
    End If
    If IsNumeric(Trim(strCol)) Then
        iCol = CInt(Trim(strCol))
        strColName = GetColumnName(iCol)
    Else
        strColName = strCol
        iCol = GetColumnNum(strCol)
   
    End If
    'get max rows
    Dim Rows_countAs Integer
    Rows_count= ActiveSheet.UsedRange.Rows.Count

    'MsgBox iRows
    Dim iCurrow As Integer
    Application.DisplayAlerts = False
   
    iCurrow = 2
    Dim strTemp1 As String
    Dim strTemp2 As String
    Dim j As Integer
    Dim icolMerge As Integer
    Dim iOriginal As Integer
    While (iCurrow < RowsCount)
        strTemp1 = ActiveSheet.Cells(iCurrow, iCol).Value
        icolMerge = iCurrow
        iOriginal = iCurrow
        If Trim(strTemp1) <> "" Then
            For j = iCurrow + 1 To RowsCount
                strTemp2 = Sheet1.Cells(j, iCol).Value
                If Trim(strTemp1) = Trim(strTemp2) Then
                  icolMerge = j
                  iCurrow = j
                Else
                  iCurrow = j
                  Exit For
                End If
               
            Next
        Else
             iCurrow = iCurrow + 1
        End If
        If (icolMerge > iOriginal) Then
            'ActiveSheet.Range(strColName & iOriginal, strColName & icolMerge).MergeCells = True
            ActiveSheet.Range(strColName & iOriginal & ":" & strColName & icolMerge).MergeCells = True
           
           
        End If
    
   
    Wend
    Application.DisplayAlerts = True
End Sub

Function GetColumnNum(ByVal ColumnName As String) As Integer
Dim Result As Integer, First As Integer, Last As Integer

Result = 1
If Trim(ColumnName) <> "" Then
    If Len(ColumnName) = 1 Then
        Result = Asc(UCase(ColumnName)) - 64
    ElseIf Len(ColumnName) = 2 Then
        If UCase(ColumnName) > "IV" Then ColumnName = "IV"
        First = Asc(UCase(Left(ColumnName, 1))) - 64
        Last = Asc(UCase(Right(ColumnName, 1))) - 64
        Result = First__*26 + Last
    End If
End If
GetColumnNum = Result

End Function


Function GetColumnName(ByVal ColumnNum As Integer) As String
Dim First As Integer, Last As Integer
Dim Result As String
If ColumnNum > 256 Then ColumnNum = 256
First = Int(ColumnNum / 27)
Last = ColumnNum - (First_*26)
If First > 0 Then
Result =_chr(First + 64)
End If
If Last > 0 Then
Result = Result &_chr(Last + 64)
End If

GetColumnName = Result
End Function


 



查阅更多相关主题的帖子: Excel VBA 自动合并单元格

评论

您还未登录,不能对文章发表评论!请先登录