Excel自动合并指定列的代码

为什么80%的码农都做不了架构师？>>>   

之前从网上找的代码有几个Bug，修正后才能用：

Sub 宏1()
'
' 宏1 宏
'
' 快捷键: Ctrl+t
    MergeCol
'
End Sub


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_count As Integer
    Rows_count = ActiveSheet.UsedRange.Rows.Count

    'MsgBox Rows_count
    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
    'MsgBox iCurrow
    While (iCurrow < Rows_count)
        strTemp1 = ActiveSheet.Cells(iCurrow, iCol).Value
        'MsgBox strTemp1
        icolMerge = iCurrow
        iOriginal = iCurrow
        If Trim(strTemp1) <> "" Then
            For j = iCurrow + 1 To Rows_count
                strTemp2 = ActiveSheet.Cells(j, iCol).Value
                'MsgBox strTemp2
                 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
            'MsgBox strColName & iOriginal & ":" & strColName & icolMerge
            '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

 

转载于:https://my.oschina.net/sqhua/blog/178115