VBA编程二--以某个标识拆分某列数据-CSDN博客

本文链接：https://blog.csdn.net/qq_69268437/article/details/145776766

注：本章所有VBA只是都围绕下述代码展开

' 单引号后面为注释

代码运行请参考文章 VBA编程一

VBA编程一--WPS如何编辑VBA代码--工具使用--环境准备_wps vba-CSDN博客

Sub 拆分B列()
    '以","拆分
    Dim i, arr, ir, k
    Dim m As Long
    Dim n As Long
    
    '获取工作表1中A列最后一行有数据的行号
    ir = Sheets(1).Range("a65536").End(xlUp).Row
    
    '从最后一行开始，向上循环到第2行
    For i = ir To 2 Step -1
        '检查B列单元格中是否包含逗号
        If InStr(Cells(i, "B"), ",") Then
            '将B列单元格的值按逗号拆分成数组
            arr = Split(Cells(i, "B").Value, ",")
            
            '从数组的最后一个元素开始，向前循环到第一个元素
            For k = UBound(arr) To LBound(arr) Step -1
                '如果当前元素是数组的第一个元素
                If k = 0 Then
                    '在当前行的下方插入一行
                    Cells(i, "B").Offset(1, 0).EntireRow.Insert xlShiftDown
                    
                    '将当前行的A列值复制到新插入的行的A列
                    Cells(i, 1).Copy
                    Cells(i + 1, 1).PasteSpecial Paste:=xlPasteValues
                    
                    '将当前行的第3到6列的值复制到新插入的行的对应列
                    For m = 3 To 6
                        Cells(i, m).Copy
                        Cells(i + 1, m).PasteSpecial Paste:=xlPasteValues
                    Next m
                    
                    '将数组中的第一个元素赋值给新插入行的B列
                    Cells(i, "B").Offset(1, 0).Value = arr(k)
                Else
                    '在当前行的下方插入一行
                    Cells(i, "B").Offset(1, 0).EntireRow.Insert xlShiftDown
                    
                    '将当前行的A列值复制到新插入的行的A列
                    Cells(i, 1).Copy
                    Cells(i + 1, 1).PasteSpecial Paste:=xlPasteValues
                    
                    '将当前行的第3列的值复制到新插入的行的第3列
                    Cells(i, 3).Copy
                    Cells(i + 1, 3).PasteSpecial Paste:=xlPasteValues
                    
                    '将数组中的当前元素赋值给新插入行的B列
                    Cells(i, "B").Offset(1, 0).Value = arr(k)
                End If
            Next k
            
            '删除当前行（因为已经将内容拆分到新行）
            Cells(i, "B").EntireRow.Delete
        End If
    Next i
End Sub