Macro to cut an paste row based on Cell value (1 Viewer)

[mattP]

Hi,

I have the following code, working off an archive button (I didn't write it, I was advised).

Basically it looks through all rows on my "Open Quotes" sheet and looks for the status in column D. If the Status is closed it cuts it out and pastes it into another worksheet "Closed Quotes" and deletes the emtpy row in "Open Quotes".

The problem I have is, when it pastes into the closed Quotes sheet,it leaves an empty line between the last quote and the newly pasted quote(s).

Any thoughts ?

Private Sub Button790_Click()
Application.ScreenUpdating = False
Dim rngOrigin As Range, rngDest As Range
Dim i, j As Integer

i = 1: j = 1
Set rngOrigin = Sheets("Open Quotes").Range("D4")
Set rngDest = Sheets("Closed Quotes").Range("A1").Offset(Application.WorksheetFunction.CountA(Sheets("Closed Quotes").Range("A:A")))

Do While rngOrigin.Offset(i, 0).Value <> ""
If rngOrigin.Offset(i, 0).Value = "Closed" Then
rngOrigin.Offset(i, 0).EntireRow.Copy
Sheets("Closed Quotes").Activate
rngDest.Offset(j, 0).Select
ActiveSheet.Paste
Sheets("Open Quotes").Activate
rngOrigin.Offset(i, 0).EntireRow.Delete xlShiftUp
j = j + 1
i = i - 1
End If
i = i + 1
Loop
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


Many thanks

MattP

 

[smiler44]

Matt,
I can not tell you what is wrong with your code but is the following any help?

Private Sub CommandButton2_Click()
Range("D1").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select
ActiveCell.Activate
If ActiveCell.Text = "closed" Then
Rows(ActiveCell.Row).Select
Selection.Cut
' extra code here if you want to move rows below up
'after cutting. not sure if the next line will work so have remmed it
'Selection.Delete Shift:=xlUp
Call anotherroute
End If
Loop
End Sub
 
 
Sub anotherroute()
Sheets("closed quotes").Select
Sheets("closed quotes").Activate
Sheets("closed quotes").Columns("D:D").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
Sheets("closed quotes").Rows(ActiveCell.Row).Select
ActiveSheet.Paste
End Sub

smiler44

 

[HaHoBe]

Hi, Matt,

why don´t you use the Autofilter and copy all records using SpecialCells(xlCellTypeVisible) instead of looping?

Private Sub Button790_Click()

Dim wsOrigin As Worksheet
Dim wsDest As Worksheet
Dim lngFirstFree As Long
Dim lngLastRow As Long
Dim lngRowCounter As Long

Application.ScreenUpdating = False
Set wsOrigin = Sheets("Open Quotes")
Set wsDest = Sheets("Closed Quotes")

lngLastRow = wsOrigin.Cells(Rows.Count, "D").End(xlUp).Row

For lngRowCounter = lngLastRow To 1 Step -1
    If UCase(wsOrigin.Cells(lngRowCounter, "D").Value) = "CLOSED" Then
        lngFirstFree = wsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1
        wsDest.Rows(lngFirstFree).Value = wsOrigin.Rows(lngRowCounter).Value
        wsOrigin.Rows(lngRowCounter).Delete
    End If
Next lngRowCounter

Set wsDest = Nothing
Set wsOrigin = Nothing
Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[VKD]

Hi, Matt,

why don´t you use the Autofilter and copy all records using SpecialCells(xlCellTypeVisible) instead of looping?

Private Sub Button790_Click()[/I]

[I]Dim wsOrigin As Worksheet[/I]
[I]Dim wsDest As Worksheet[/I]
[I]Dim lngFirstFree As Long[/I]
[I]Dim lngLastRow As Long[/I]
[I]Dim lngRowCounter As Long[/I]

[I]Application.ScreenUpdating = False[/I]
[I]Set wsOrigin = Sheets("Open Quotes")[/I]
[I]Set wsDest = Sheets("Closed Quotes")[/I]

[I]lngLastRow = wsOrigin.Cells(Rows.Count, "D").End(xlUp).Row[/I]

[I]For lngRowCounter = lngLastRow To 1 Step -1[/I]
[I]    If UCase(wsOrigin.Cells(lngRowCounter, "D").Value) = "CLOSED" Then[/I]
[I]        lngFirstFree = wsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1[/I]
[I]        wsDest.Rows(lngFirstFree).Value = wsOrigin.Rows(lngRowCounter).Value[/I]
[I]        wsOrigin.Rows(lngRowCounter).Delete[/I]
[I]    End If[/I]
[I]Next lngRowCounter[/I]

[I]Set wsDest = Nothing[/I]
[I]Set wsOrigin = Nothing[/I]
[I]Application.ScreenUpdating = True[/I]

[I]End Sub

Ciao,
Holger

This is great but and I have got it to work using a click button but I want to cut and paste more than one line. Which is is doing but it keeps putting the pasted cells in the same row, eg if I have three rows to cut and paste it pastes them all onto one row (which means you are left with just the final row) and deletes all the other cells.

Here's my code if that helps
Lasta = FindLastRowInMultiRange(DataPage, 1, 83, FirstRowWorkbank, 65536)
ThisWorkbook.Sheets(ArchivePage).Activate
apasterow = FindLastRowInMultiRange(ArchivePage, 1, 89, FirstRowArchive, 65536)

ThisWorkbook.Sheets(DataPage).Activate
For lngRowCounter = Lasta To 1 Step -1

If ASourcePg.Cells(lngRowCounter, "Q").Value = "Yes" Then
apasterow = apasterow + 1
ArchivePg.Rows(apasterow).FormulaR1C1 = ASourcePg.Rows(Lasta).FormulaR1C1
ASourcePg.Rows(lngRowCounter).Delete
End If
Next lngRowCounter

 

[Brianwarnock]

You have also asked this quetion in the Visual Basic forum.

Why have you not modified Holger's code.?

Brian

 

[VKD]

Yes, Sorry didn't know if it should be in VB or excel. I don't understand what you mean about why haven't you modifed the code?? I have tried but I am not sure where I am going wrong hence why I wondered if anyone could point me in the right direction.

 

[Brianwarnock]

Matt asked aquestion almost identical to yours and Holger( aka HaHoBe) posted a reply, I was asking why hadn't you used his code modified to your requirements rather than post your own code which isn't working.
Is that 2007 , I ask as it means little to me.

Brian

 

[VKD]

My point is that I am using Holger's code (changed slightly for the nameing I have set up) but it is pasting all the data in the same line and not moving down a row. I have tried using lngFirstFree = wsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1 but that only pastes in the 1st row in the worksheet and overwrites any pervious data you had there.

 

[VKD]

No worries, figured this one out now. Now onto the next problem!!