需求：

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

 

分析：

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

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

自动判断所有的行数；

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

难点:

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

源代码：


Option Explicit

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