求助 请大神帮忙查看一下什么原因造成死机

willem168

运行下列代码 excel会死机行数也不算多 测试10行可以过此代码 求大神优化一下





Sub DeleteRows()
    Application.ScreenUpdating = False
    Dim i As Long, ii As Integer
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("欠费统计1") ' 修改为你的工作表名
    For i = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1 To 1 Step -1
        x = ""
        For ii = 1 To 12
            If ws.Cells(i, ii + 2).Value <> "" Then
                x = ws.Cells(i, ii + 2).Value
                Exit For
            End If
        Next ii
        If x = "" Then ws.Rows(i).Delete
    Next i
    Application.ScreenUpdating = True
End Sub





补充内容 (2024-9-8 13:37):
感谢各位大师的指点但是最后实际数据处理需要2万多条 最后还是改用sql 获取 Sub 统计数量01()

  ThisWorkbook.Sheets("2016年（办公） ").[a2].Resize(1, 14).Copy Destination:=ThisWorkbook.Sheets("欠费统计2...

willem168

大神救命啊

xjl565135022

VBA删除不连续的行，用for循环遍历、判断后一条一条的删除的效率是很低的，想要快，大致思路是先将这些行连续起来，再批量删除。比如你的需求是将C列至N列没有内容的行删除，你可以用for遍历出没有内容的行并标记在辅助列上，比如第二行没有内容，就在P2上标记1，最后再把P列排序一下，这样所有需要删除的行就连续了，这样一次性删除一秒都不用

quqiyuan

要使用数组或者字典才能提高速度，不停读取单元格，速度超慢，搞了下，速度提高了，供你参考。。。

quqiyuan

代码如下。。。。

Sub DeleteRows()
    t = Timer
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim i As Long, ii As Integer
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("欠费统计1") ' 修改为你的工作表名
    arr = ws.UsedRange
    For i = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row To 1 Step -1           '原来是有-1，不明白为什么，不是应该是最后一行开始吗？
        x = ""
        For ii = 1 To 12
            If Len(arr(i, ii + 2)) <> 0 Then
                x = arr(i, ii + 2)
                Exit For
            End If
        Next ii
        If x = "" Then If rng Is Nothing Then Set rng = ws.Rows(i) Else Set rng = Union(rng, ws.Rows(i))
    Next i
    rng.Delete
    Application.ScreenUpdating = True
    MsgBox "共耗时：" & Timer - t
End Sub

willem168

xjl565135022 发表于 2024-9-3 17:31
VBA删除不连续的行，用for循环遍历、判断后一条一条的删除的效率是很低的，想要快，大致思路是先将这些行连 ...

Sub DeleteRows()
    Application.ScreenUpdating = False
    Dim i As Long, ii As Integer
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("欠费统计1") ' 修改为你的工作表名
    For i = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row - 1 To 1 Step -1
        x = ""
        For ii = 1 To 12
            If ws.Cells(i, ii + 2).Value <> "" Then
                x = ws.Cells(i, ii + 2).Value
                Exit For
            End If
        Next ii
       If x <> "" Then ws.Cells(i, 18) = "有数据"
    Next i
    Application.ScreenUpdating = True
End Sub


果然 我把删行改成标记 也就1秒不到 果然是 不能一条一条删除

willem168

quqiyuan 发表于 2024-9-3 17:38
代码如下。。。。

Sub DeleteRows()

受教了大师 多谢指导

willem168

quqiyuan 发表于 2024-9-3 17:38
代码如下。。。。

Sub DeleteRows()

测试的时候 吧合计删除了

willem168

万分感谢各位大师的指导
Sub DeleteRows2()


    Dim t As Double
    t = Timer
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim i As Long, ii As Integer
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("欠费统计1")
    arr = ws.UsedRange
    For i = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row To 1 Step -1
    Debug.Print i
   
        x = ""
        For ii = 1 To 12
            If Len(arr(i, ii + 2)) <> 0 Then
                x = arr(i, ii + 2)
                Exit For
            End If
        Next ii
        If x = "" Then
            If rng Is Nothing Then
                Set rng = ws.Rows(i)
            Else
                Set rng = Union(rng, ws.Rows(i))
            End If
        End If
    Next i
    If Not rng Is Nothing Then rng.Delete
    Application.ScreenUpdating = True
    MsgBox "共耗时：?" & Timer - t
End Sub

xjl565135022

Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("欠费统计1")
arr = ws.Range("A1:Q" & [A65536].End(3).Row)
For i = 2 To UBound(arr)
    arr(i, 16) = i
    Data = False
    For j = 3 To 14
        If arr(i, j) <> "" Then
            Data = True
            Exit For
        End If
    Next
    If Data = True Then
        arr(i, 17) = 1
    End If
Next
ws.Range("A1:Q" & [A65536].End(3).Row) = arr
ws.Range("A1:Q" & [A65536].End(3).Row).Sort key1:=Range("Q1"), order1:=xlAscending, Header:=xlYes
ws.Rows([Q65536].End(3).Row + 1 & ":" & UBound(arr)).Delete
ws.Range("A1:Q" & [A65536].End(3).Row).Sort key1:=Range("P1"), order1:=xlAscending, Header:=xlYes
End Sub
有合并单元格的话不能排序，要先取消合并单元格