|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub test()
Dim i&, n&, j&, r&
Dim arr(), brr(), crr, rng As Range
Application.ScreenUpdating = False
crr = Sheet2.Range("a1").CurrentRegion.Offset(1)
For i = 1 To UBound(crr)
If crr(i, 13) <> "" Then
n = n + 1
ReDim Preserve arr(1 To n)
arr(n) = i
End If
Next
If n = 0 Then
MsgBox "未发现代处理的数据!", 64
Exit Sub
End If
ReDim brr(1 To n, 1 To UBound(crr, 2))
For i = 1 To UBound(arr)
For j = 1 To UBound(crr, 2)
brr(i, j) = crr(arr(i), j)
Next
Next
With Sheet2
For i = 1 To UBound(arr)
If rng Is Nothing Then
Set rng = .Rows(arr(i) + 1)
Else
Set rng = Union(rng, .Rows(arr(i) + 1))
End If
Next
rng.Delete
End With
With Sheet3
r = .Range("a" & Rows.Count).End(xlUp).Row + 1
.Rows(r).Interior.Color = vbRed
.Range("a" & r).Resize(UBound(brr), UBound(brr, 2)) = brr
.Select
End With
MsgBox "共移动" & n & "条记录"
End Sub
|
|