[人工智能]Excel VBA多行连续数据分类合并

Excel VBA多行连续数据分类合并

1. 案例说明:

需要将如下数据

合并为以下形式,并且新建一个工作表展示出来:

2. 实现代码:

打开EXCEL的VBA环境,将以下代码复制粘贴到新的模块中，运行"多行合并"这个Sub即可

Option Explicit

Private Function SheetExists(sname) As Boolean
'   Returns TRUE if sheet exists in the active workbook
    Dim x As Object
    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(sname)
    If Err = 0 Then SheetExists = True _
        Else SheetExists = False
End Function
 

Sub 多行合并()
    Dim new_sht As Worksheet
    Dim source_sht As Worksheet
    Dim last_row As Long
    Dim last_column As Long
    Dim temp_rng As Range
    Dim write_rng As Range
    Dim cur_row As Long
    
    
    Set source_sht = ActiveSheet
    If Not SheetExists("合并后的表") Then
        Set new_sht = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
        new_sht.Name = "合并后的表"
        new_sht.UsedRange.Clear
    Else
        Set new_sht = Worksheets("合并后的表")
    End If
    ' 把原表激活
    source_sht.Activate
    last_row = source_sht.Cells(Rows.Count, 1).End(xlUp).Row
    Set write_rng = new_sht.[a1]
    
    For cur_row = 1 To last_row
        If cur_row = 1 Then
            last_column = source_sht.[a1].End(xlToRight).Column
            Set temp_rng = source_sht.Range(Range("a1"), Cells(1, last_column))
            new_sht.[a1].Resize(1, temp_rng.Count) = temp_rng.Value
            Set write_rng = new_sht.[a1].End(xlToRight).Offset(0, 1)
        Else
            If source_sht.Cells(cur_row, "a").Value = source_sht.Cells(cur_row - 1, "a").Value Then
                last_column = source_sht.Cells(cur_row, "a").End(xlToRight).Column
                Set temp_rng = source_sht.Range(Cells(cur_row, "b"), Cells(cur_row, last_column))
                write_rng.Resize(1, temp_rng.Count) = temp_rng.Value
    
                Set write_rng = write_rng.End(xlToRight).Offset(0, 1)
            Else
                last_column = source_sht.Cells(cur_row, "a").End(xlToRight).Column
                Set temp_rng = source_sht.Range(Cells(cur_row, "a"), Cells(cur_row, last_column))
                new_sht.Cells(write_rng.Row + 1, "a").Resize(1, temp_rng.Count) = temp_rng.Value
                last_column = source_sht.Cells(cur_row, "a").End(xlToRight).Column
                Set write_rng = new_sht.Cells(write_rng.Row + 1, "a").End(xlToRight).Offset(0, 1)
            End If
        
        End If
    
    Next cur_row
End Sub