Need suggestions with my code to cut and paste the rows

[megha]

Hello,

I have a excel workbook with two sheets; 1) Work 2) Completed with long list on sheet1 (Work). When ever I am done with any of the item(s) listed on Sheet1(Work) I put "X" in column "H." I have my command button on sheet2 (Completed) which cut the done items (rows with "X") from sheet1(work) and paste it to sheet2 (Completed). Its work fine but it left blank rows on sheet1(work). I don't want the blank rows once the text moved to sheet2(Completed). Any suggestions? Please help! I have copied my code.

Const MONITOR_COLUMN_1 As String = "H"
'Const MONITOR_COLUMN_2 As String = "G"
'Const MONITOR_COLUMN_3 As String = "H"
 
Const COMPLETED_WORKSHEET As String = "Completed"
Private Sub CommandButton1_Click()
    Dim shCompleted As Worksheet
    Set shCompleted = Worksheets(COMPLETED_WORKSHEET)
    Dim sh As Worksheet
    For Each sh In Worksheets
        If sh.Name <> COMPLETED_WORKSHEET Then
            Dim db As Range
            Set db = sh.UsedRange
            Dim rRow As Range
            For Each rRow In db.Rows
                If rRow.Cells(1, MONITOR_COLUMN_1).Value = "X" _
                 Then
                    If Not DataExists(shCompleted, rRow) Then
                        rRow.Cut Destination:=shCompleted.Range("A" & Rows.Count).End(xlUp).Offset(1)
                    End If
                End If
            Next rRow
        End If
    Next sh
MsgBox "Macro has finished processing"
End Sub
 
Function DataExists(sh As Worksheet, r As Range) As Boolean
     'This function assumes that the Range r is a single row
    Dim db As Range
    Set db = sh.UsedRange
    Dim rRow As Range
    Dim dataIdentical As Boolean
    For Each rRow In db.Rows
        dataIdentical = True
        Dim iCol As Integer
        For iCol = 1 To r.Columns.Count
            If rRow.Cells(1, iCol) <> r.Cells(1, iCol) Then
                dataIdentical = False
                Exit For
            End If
        Next iCol
        If dataIdentical Then
            DataExists = True
            Exit Function
        End If
    Next rRow
    DataExists = False
End Function

 

[VoG]

Hopefully you can see where this goes

            Next rRow
            On Error Resume Next
            db.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            On Error GoTo 0
        End If

 

[Rick Rothstein]

The following code will be much faster than the code you posted; it will move the data where there is an X (actually, any entry) in Column H (this assumes Column H contains no other entries besides X's) and then delete the rows that have been moved...

Sub MoveWork()
  Dim NextEmptyCompletedRow As String
  Const SheetForWork As String = "Sheet1"
  Const SheetForCompleted As String = "Sheet2"
  Const XMarksTheSpotColumn As String = "H"
  NextEmptyCompletedRow = Worksheets(SheetForCompleted).Cells(Rows.Count, "A").End(xlUp).Row + 1
  On Error GoTo NothingToMove
  With Worksheets(SheetForWork).Columns(XMarksTheSpotColumn).SpecialCells(xlCellTypeConstants).EntireRow
    .Copy Worksheets(SheetForCompleted).Cells(NextEmptyCompletedRow, "A")
    .Delete
  End With
  Worksheets(SheetForCompleted).Columns("H").Clear
NothingToMove:
End Sub

The only thing you need to do is change, if necessary, the assignments I made to the Const (VB keyword for constant) statements in case I got the sheet names wrong. This code is a macro and can be assigned to your button.

 

[megha]

Yupe, it did work. Thank you so much! Thanks Rick Rothstein and VoG.