如何改进此代码, 在清晰内容后移动范围?
原标题：how to improve this code to shift the range up after clear contents?
Hi I have 2 tables in this sheet hence i m unable to delete row.
Can you share how to modify this code to shift the row up from Column A to E if it s empty?
Sub Test()
Dim ws As Worksheet
Dim e As Variant
Dim lr As Long
Dim r As Long
Set ws = ThisWorkbook.Sheets("Current")
With Sheets("Archive")
For r = 1 To ws.Cells(Rows.Count, 2).End(xlUp).Row
If ws.Cells(r, 4) = "Done" Then
lr = .Cells(Rows.Count, 2).End(xlUp).Row + 1
For Each e In Array("A", "B", "C", "D", "E")
.Range(e & lr) = ws.Range(e & r)
ws.Range(e & r).ClearContents
Next e
End If
Next r
End With
Range("A:E").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End Sub
最佳回答
Try this mod
Sub Test()
Dim ws As Worksheet
Dim e As Variant
Dim lr As Long
Dim r As Long
Dim range_to_del as Range
Set ws = ThisWorkbook.Sheets("Current")
Set range_to_del = ws.Range("CCC1") set to a cell somewhere at the right end of the sheet which column is not used
With Sheets("Archive")
For r = 1 To ws.Cells(Rows.Count, 2).End(xlUp).Row
If ws.Cells(r, 4) = "Done" Then
lr = .Cells(Rows.Count, 2).End(xlUp).Row + 1
For Each e In Array("A", "B", "C", "D", "E")
.Range(e & lr) = ws.Range(e & r)
Next e
Set range_to_del = Union(range_to_del, ws.Range("A" & r & ":E" & r))
End If
Next r
End With
range_to_del.Delete xlShiftUp
Range("A:E").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End Sub
range_to_del collects the rows which are copied and at the end of the copying removes the copied rows from the sheet Current.
问题回答
Copy Matching Rows (Archive Data)
Before
After
Sub ArchiveData()
Const PROC_TITLE As String = "Archive Data"
Dim Msg As String
On Error GoTo ClearError out-comment if error message to troubleshoot!
Msg = "Defining constants"
Source
Const SRC_SHEET_NAME As String = "Current"
Const SRC_COLUMNS As String = "A:E"
Const SRC_FIRST_ROW As Long = 2
Const SRC_SEARCH_COLUMN As Long = 4 n-th column of SRC_COLUMNS !
Const SRC_SEARCH_STRING As String = "Done"
Destination
Const DST_SHEET_NAME As String = "Archive"
Const DST_FIRST_CELL_ADDRESS As String = "A2"
Other
Const MATCH_CASE As Boolean = False
Const DO_NOT_DELETE_ROWS As Boolean = True reset when finished testing!
Const SHOW_MESSAGES As Boolean = True
Msg = "Referencing the workbook"
Dim wb As Workbook: Set wb = ThisWorkbook workbook containing this code
Msg = "Retrieving source information"
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range, sfrg As Range, slcell As Range, sRowsCount As Long
With sws.Rows(SRC_FIRST_ROW).Columns(SRC_COLUMNS) first row
Set sfrg = .Resize(sws.Rows.Count - .Row + 1) find range
Set slcell = sfrg.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If slcell Is Nothing Then last non-empty cell by rows
If SHOW_MESSAGES Then
MsgBox "No data found in "" " & sws.Name & " !" _
& sfrg.Address(0, 0) & """!", vbExclamation
Exit Sub
End If
End If
sRowsCount = slcell.Row - .Row + 1
Set srg = .Resize(sRowsCount)
End With
Dim scrg As Range: Set scrg = srg.Columns(SRC_SEARCH_COLUMN) search range
Dim scData() As Variant:
If sRowsCount = 1 Then
ReDim scData(1 To 1, 1 To 1)
scData(1, 1) = scrg.Value
Else
scData = scrg.Value
End If
Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
If ColumnsCount < SRC_SEARCH_COLUMN Then
MsgBox "The source range "" " & sws.Name & " !" _
& srg.Address(0, 0) & """ has fewer than " & SRC_SEARCH_COLUMN _
& " columns!", vbExclamation, PROC_TITLE
Exit Sub
End If
Msg = "Combining matching rows into unioned range"
Dim CompareMethod As Long: CompareMethod = MATCH_CASE + 1
Dim surg As Range, srrg As Range, sValue As Variant
Dim sRow As Long, dRowsCount As Long, WasSearchStringFound As Boolean
For sRow = 1 To sRowsCount
sValue = scData(sRow, 1)
If Not IsError(sValue) Then
If StrComp(sValue, SRC_SEARCH_STRING, CompareMethod) = 0 Then
dRowsCount = dRowsCount + 1
Set srrg = srg.Rows(sRow)
If WasSearchStringFound Then
Set surg = Union(surg, srrg)
Else
Set surg = srrg
WasSearchStringFound = True
End If
End If
End If
Next sRow
If Not WasSearchStringFound Then
If SHOW_MESSAGES Then
MsgBox "No rows with """ & SRC_SEARCH_STRING & """ in "" " _
& sws.Name & " !" & scrg.Address(0, 0) & """ found!", _
vbExclamation, PROC_TITLE
End If
Exit Sub
End If
Msg = "Retrieving destination information"
Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
If dws.FilterMode Then dws.ShowAllData
Dim drg As Range, dfrg As Range, dlcell As Range, dRowOffset As Long
With dws.Range(DST_FIRST_CELL_ADDRESS).Resize(, ColumnsCount) first row
Set dfrg = .Resize(dws.Rows.Count - .Row + 1) find range
Set dlcell = dfrg.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not dlcell Is Nothing Then last non-empty cell by rows
dRowOffset = dlcell.Row - .Row + 1
End If
Set drg = .Offset(dRowOffset).Resize(dRowsCount)
End With
Msg = "Archiving rows"
surg.Copy Destination:=drg
Dim sAddress As String: sAddress = srg.Address(0, 0)
Dim scAddress As String: scAddress = scrg.Address(0, 0)
If Not DO_NOT_DELETE_ROWS Then surg.Delete Shift:=xlShiftUp
Msg = "Informing"
If SHOW_MESSAGES Then
MsgBox dRowsCount & " row" & IIf(dRowsCount = 1, "", "s") & " of "" " _
& sws.Name & " !" & sAddress & """ with """ _
& SRC_SEARCH_STRING & """ in """ & scAddress & " " _
& IIf(DO_NOT_DELETE_ROWS, "copie", "move") & "d to "" " _
& dws.Name & " !" & drg.Address(0, 0) & """.", _
vbInformation, PROC_TITLE
End If
ProcExit:
Exit Sub
ClearError: e.g. not enough rows in the destination sheet
MsgBox "Run-time error [" & Err.Number & "]: (while " & LCase(Msg) & ")" _
& vbLf & vbLf & Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Sub
