求助一个根据统计非空单元格数量插入行及填充数据的问题

huishi

Sub ProcessData()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim currentRow As Long
    Dim nonEmptyCount As Long
    Dim i As Long, j As Long
    Dim insertRows As Long
    Dim cell As Range
   
    Set ws = ThisWorkbook.Sheets("123") ' 修改为你的工作表名称
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row ' 找到最后一行
   
    For currentRow = 2 To lastRow ' 从第二行开始
        ' 统计当前行E到AA的非空单元格数量
        nonEmptyCount = Application.WorksheetFunction.CountA(ws.Range(ws.Cells(currentRow, "E"), ws.Cells(currentRow, "AA")))
        
        If nonEmptyCount > 0 Then
            ' 计算需要插入的行数
            insertRows = nonEmptyCount - 1
            
            ' 在当前行下方插入行
            If insertRows > 0 Then
                ws.Rows(currentRow + 1 & ":" & currentRow + insertRows).Insert Shift:=xlDown
            End If
            
            ' 填充A列和C列
            ws.Range(ws.Cells(currentRow, "A"), ws.Cells(currentRow + insertRows, "A")).Value = ws.Cells(currentRow, "A").Value
            ws.Range(ws.Cells(currentRow, "C"), ws.Cells(currentRow + insertRows, "C")).Value = ws.Cells(currentRow, "C").Value
            
            ' 数据转置到D列
            j = 0
            For Each cell In ws.Range(ws.Cells(currentRow, "E"), ws.Cells(currentRow, "AA"))
                If Not IsEmpty(cell.Value) Then
                    ws.Cells(currentRow + j, "D").Value = cell.Value
                    j = j + 1
                End If
            Next cell
            
            ' 数据转置到B列
            j = 0
            For i = 1 To 23 ' E1到AA1共23列
                If Not IsEmpty(ws.Cells(1, i + 4).Value) And Not IsEmpty(ws.Cells(currentRow, i + 4).Value) Then
                    ws.Cells(currentRow + j, "B").Value = ws.Cells(1, i + 4).Value
                    j = j + 1
                End If
            Next i
            
            ' 更新lastRow
            lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
        End If
        
        ' 跳过插入的行
        currentRow = currentRow + insertRows
    Next currentRow
End Sub


[url=]新建 XLSX 工作表 - 副本.rar[/url]

执行上述代码后，AA列有空单元格的，都不能执行插入行，大神们看看代码是哪里出了问题，帮忙修改一下

小凡、、、

感觉ai写的逻辑不怎么喜欢用do循环

ykcbf1100

附件供参考。。。
AI写的代码大多数时候不好用，除非是特别具体的而又相对简单的AI的代码才会有参考价值，如：简单的正则表达式。

ykcbf1100

参与一下。。。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    With ThisWorkbook.Sheets("123")
        lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
        arr = .[a1].CurrentRegion
        Set d = CreateObject("scripting.dictionary")
        For i = lastRow To 2 Step -1
            d.RemoveAll: n = 0
            For j = 5 To UBound(arr, 2)
                If arr(i, j) <> Empty Then d(arr(1, j)) = arr(i, j)
            Next
            If d.Count - 1 > 0 Then
                Rows(i + 1).Resize(d.Count - 1).Insert xlShiftDown
                n = i
                For Each k In d.keys
                    If .Cells(n, 1) = Empty Then .Cells(n, 1) = .Cells(n - 1, 1)
                    If .Cells(n, 3) = Empty Then .Cells(n, 3) = .Cells(n - 1, 3)
                    .Cells(n, 2) = k
                    .Cells(n, 4) = d(k)
                    n = n + 1
                Next
            End If
        Next
        .UsedRange.Borders.LineStyle = 1
    End With
    Beep
End Sub
   
   

huishi

ykcbf1100 发表于 2024-10-18 16:27
附件供参考。。。
AI写的代码大多数时候不好用，除非是特别具体的而又相对简单的AI的代码才会有参考价值， ...

插入行，以及A、B、C列填充都没有问题，有问题的是E到AA列的数据转置到D列时，该行有不相同的数值，但转置到D列的数据都是相同的，比如E11：AA11，有44331，但转置后都是44444

ykcbf1100

huishi 发表于 2024-10-18 20:53
插入行，以及A、B、C列填充都没有问题，有问题的是E到AA列的数据转置到D列时，该行有不相同的数值，但转 ...

对题意理解有误，改一下吧。

ykcbf1100

icenotcool 发表于 2024-10-18 21:01
ykcbf1100老师可以看看我的求助帖吗？谢谢你了https://club.excelhome.net/thread-1703998-1-1.html?_dsi ...

我对窗体不熟悉啊

huishi

小凡、、、 发表于 2024-10-18 15:00
感觉ai写的逻辑不怎么喜欢用do循环

当E到AA列当前行非空等于1时，代码执行插入3行，首尾行填充，中间行空白