Copy/Paste Rows on select criteria

[UTB]

Hello All,

Long time reader first time poster.

I am in the process of automating some stuff using VBA on Excel (basically transferring of data from one worksheet to another at the click of a button).

So far I have managed to copy/paste an entire row from the source worksheet (Hotels WIP) to the destination worksheet (Hotel 2) based on identified criteria in one of the cells (Cells in column P) in the source worksheet. However……the problem I am stuck with is that it is copying over the entire row which contains the set criteria and I only want it to copy over from A:P in this instance and no further as data in the column Q onwards is not relevant in the destination worksheet (if that makes sense?
I know my issue is within the VBA code but I’m at a loss as to how to correct what is happening and having tried for weeks not to correct it, I am admitting it is now beyond my very basic VBA abilities.

I would be very grateful if someone could take a look at my current code and see if there is a solution I just cannot see;


————————————————————

Current Button Click:

Sub Button3_Click()

'Declare variables

Dim sheetNo1 As Worksheet

Dim sheetNo2 As Worksheet

Dim FinalRow As Long

Dim Cell As Range

'Set variables

Set sheetNo1 = Sheets("Hotel - WIP")

Set sheetNo2 = Sheets("Hotel2")

'Type a command to select the entire row

Selection.EntireRow.Select

' Define destination sheets to move row

FinalRow1 = sheetNo1.Range("A" & sheetNo1.Rows.Count).End(xlUp).Row

FinalRow2 = sheetNo2.Range("A" & sheetNo2.Rows.Count).End(xlUp).Row

With sheetNo1

'Apply loop for column P until last cell with value

For Each Cell In .Range("P3:P" & .Cells(.Rows.Count, "P").End(xlUp).Row)

'Apply condition to match the "Hotel Book" value

If Cell.Value = "Hotel Book" Then

'Command to Copy and move to a destination Sheet "Hotel2"

.Rows(Cell.Row).Copy Destination:=sheetNo2.Rows(FinalRow2 + 1)

FinalRow2 = FinalRow2 + 1

'Apply condition to match the "Hotel File" value

ElseIf Cell.Value = "Hotel File" Then

'Command to Copy and move to a destination Sheet "Hotel2"

.Rows(Cell.Row).Copy Destination:=sheetNo2.Rows(FinalRow2 + 1)

FinalRow2 = FinalRow2 + 1

End If

Next Cell

End With

End Sub

————————————————————

As I say that above code transfers the entire row to the end of the worksheet and all that goes with it including blank cells etc when all I want to do is transfer A-P based on if cells in P contain either of those two designated words.

Many thanks in advance.

 

[Osvaldo Palmeiro]

Hi.
Try changing the two occurrences of the line below.

from:

.Rows(Cell.Row).Copy Destination:=sheetNo2.Rows(FinalRow2 + 1)

to:

.Cells(Cell.Row, "A").Resize(, 16).Copy Destination:=sheetNo2.Cells(FinalRow2 + 1, "A")

As an option, the new code below seems to do the job as well.

Sub Button3_Click()
 'Declare variables
 Dim Cell As Range
  With Sheets("Hotel - WIP")
   'Apply loop for column P until last cell with value
   For Each Cell In .Range("P3:P" & .Cells(Rows.Count, "P").End(xlUp).Row)
   'Apply condition to match the "Hotel Book" or the Hotel File value
    If Cell.Value = "Hotel Book" Or Cell.Value = "Hotel File" Then
    'Command to Copy and move to a destination Sheet "Hotel2"
    .Cells(Cell.Row, "A").Resize(, 16).Copy Sheets("Hotel2").Cells(Rows.Count, "A").End(3)(2)
    End If
   Next Cell
  End With
End Sub

 

[kevin9999]

Rather than copy one row at a time, why not copy all of them en masse. I note you're starting your current loop from row 3 - so I'm assuming your headers are on row 2? A small sample of your data would be useful.

Option Explicit
Sub Copy_En_Masse()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Hotel - WIP")
    Set ws2 = Worksheets("Hotel2")
    
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    With ws1.Range("A2:P" & ws1.Cells(Rows.Count, "A").End(xlUp).Row)
        .AutoFilter 16, "Hotel Book"
        .Offset(1).Copy ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
    End With
End Sub

 

[UTB]

Hi.
Try changing the two occurrences of the line below.

from:

.Rows(Cell.Row).Copy Destination:=sheetNo2.Rows(FinalRow2 + 1)

to:

.Cells(Cell.Row, "A").Resize(, 16).Copy Destination:=sheetNo2.Cells(FinalRow2 + 1, "A")

As an option, the new code below seems to do the job as well.

Sub Button3_Click()
 'Declare variables
 Dim Cell As Range
  With Sheets("Hotel - WIP")
   'Apply loop for column P until last cell with value
   For Each Cell In .Range("P3:P" & .Cells(Rows.Count, "P").End(xlUp).Row)
   'Apply condition to match the "Hotel Book" or the Hotel File value
    If Cell.Value = "Hotel Book" Or Cell.Value = "Hotel File" Then
    'Command to Copy and move to a destination Sheet "Hotel2"
    .Cells(Cell.Row, "A").Resize(, 16).Copy Sheets("Hotel2").Cells(Rows.Count, "A").End(3)(2)
    End If
   Next Cell
  End With
End Sub

Thank you for that. The first tiny change was the thing that fixed it to do exactly as I was hoping!

Your help has been very much appreciated.

Thanks

 

[UTB]

Rather than copy one row at a time, why not copy all of them en masse. I note you're starting your current loop from row 3 - so I'm assuming your headers are on row 2? A small sample of your data would be useful.

Option Explicit
Sub Copy_En_Masse()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Hotel - WIP")
    Set ws2 = Worksheets("Hotel2")
   
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    With ws1.Range("A2:P" & ws1.Cells(Rows.Count, "A").End(xlUp).Row)
        .AutoFilter 16, "Hotel Book"
        .Offset(1).Copy ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
    End With
End Sub

Thank you for your response.

The first reply managed to fix the issue I was having and the system does exactly what I intended for it to do.

Your help has been very much appreciated.

Thanks.