我正在尝试使用 VBA 将数据复制到 Excel 中的新工作表。我希望在标记为“完成”时将数据传输到工作表。我对下面代码的问题是数据总是移动到表 2 中的 B 行,反复覆盖自身。我希望将数据复制到第二张表中 B、C、D、E 等列中的新行。
代码:
Sub Move_When_Completed()
'Created by Excel 10 Tutorial
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("To_Do").UsedRange.Rows.Count
B = Worksheets("Done").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Done").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("To_Do").Range("E1:E" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "Complete" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Done").Range("A" & Rows.Count).End(xlUp).Offset(1)
xRg(C).EntireRow.Delete
If CStr(xRg(C).Value) = "Complete" Then
C = C - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
................................
Sub MoveCompleted()
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it isn't, reference it by name or use 'ActiveWorkbook'.
' Reference the source objects.
Dim sws As Worksheet: Set sws = wb.Sheets("To_Do")
Dim srg As Range: Set srg = sws.UsedRange.Columns("E")
' Reference the destination objects.
Dim dws As Worksheet: Set dws = wb.Sheets("Done")
Dim dcell As Range:
With dws.UsedRange.EntireRow.Columns("A")
Set dcell = .Cells(.Cells.Count).Offset(1)
End With
' Declare additional variables.
Dim surg As Range, sRow As Long, scell As Range
' Loop through the cells of the source range
' and add the matching (completed) cells to a unioned range.
For Each scell In srg.Cells
If CStr(scell.Value) = "Complete" Then ' E<>e
'If StrComp(CStr(scell.Value), "Complete", vbTextCompare) = 0 Then ' E=e
If surg Is Nothing Then
Set surg = scell
Else
Set surg = Union(surg, scell)
End If
End If
Next scell
' Check if any matching cells were found and retrieve their number.
Dim MatchingRowsCount As Long
If Not surg Is Nothing Then MatchingRowsCount = surg.Cells.Count
' Copy and delete the entirerows of the unioned range.
If MatchingRowsCount > 0 Then
Application.ScreenUpdating = False
With surg.EntireRow
.Copy Destination:=dcell
.Delete Shift:=xlShiftUp
End With
Application.ScreenUpdating = True
End If
' Inform.
If MatchingRowsCount > 0 Then
MsgBox MatchingRowsCount & " completed row" _
& IIf(MatchingRowsCount = 1, "", "s") & " moved.", vbInformation
Else
MsgBox "No completed rows found!", vbExclamation
End If
End Sub