速度太慢了，请老师帮忙改改！

SCWYZJ

求助：我的数据有很多条，但代码运行太慢了，请老师帮忙看看有没有跟快的办法。（见附件）谢谢！

liulang0808

Sub 自动填充()
Application.ScreenUpdating = False
Application.Calculation = xlManual
r = ThisWorkbook.Sheets(1).Range("D65535").End(xlUp).Row
For I = 4 To r
    With ThisWorkbook.Sheets(1)
        If .Cells(I, 4) > 0 Then
            .Cells(I, 5) = "中国"
            .Cells(I, 6) = "北京"
        End If
    End With
    Next
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
    MsgBox "填充完毕!"
End Sub

abc123281

可以改用数组
Sub 自动填充()
Dim arr, brr(1 To 1000000, 1 To 2)
With Worksheets("Sheet1")
  r = .Range("d65536").End(xlUp).Row
  arr = .Range("d4:h" & r)
  For i = 1 To UBound(arr)
    If arr(i, 1) > 0 Then
       n = n + 1
       brr(n, 1) = "中国"
       brr(n, 2) = "北京"
    End If
  Next
  .Range("e4").Resize(n, 2) = brr
End With
MsgBox "填充完毕!", 64
End Sub

SCWYZJ

谢谢2楼。3楼老师的帮忙，都符合我的要求，多向您们学习！