".EntireRow.Copy Destination:=" to specific range

ToseSenpai

New Member
Joined
Apr 18, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have this VBA code that i can use for search a specific value (for example "R") in a sheet and then copy the row with the specific value in an other sheet.
How can i copy only a specific range instead the entire row?
".EntireRow.Copy Destination:=destRng"
I need to copy only A-B-C-D-F the specific row, not entire row.

Thank you very much for your help :giggle:


VBA Code:
Public Sub SMACROTRRRR()

    Dim WB As Workbook
    Dim srcSH As Worksheet, destSH As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim rCell As Range
    Dim delRng As Range
    Dim iLastRow As Long, jLastRow As Long

    Const sStr As String = "R"                                                                    '<<==== Edit


    Set WB = ThisWorkbook

    With WB
    Set srcSH = .Sheets("MEMO")                                                             '<<==== Edit
    Set destSH = .Sheets("ARCHIVIO RETTIFICHE")                                                           '<<==== Edit
    End With

    With srcSH
        iLastRow = LastRow(srcSH, .Columns("A:A"))
        Set srcRng = .Range("A1:A" & iLastRow)
    End With

    With destSH
        jLastRow = LastRow(destSH, .Columns("A:A"))
        Set destRng = .Range("A" & jLastRow + 1)
    End With

    On Error GoTo XIT
    Application.ScreenUpdating = False
    For Each rCell In srcRng.Columns(24).Cells
        With rCell
            If UCase(.Value) = UCase(sStr) Then
                If delRng Is Nothing Then
                    Set delRng = rCell
                Else
                    Set delRng = Union(rCell, delRng)
                End If
            End If
        End With
    Next rCell

    If Not delRng Is Nothing Then
        With delRng
       
            .EntireRow.Copy Destination:=destRng
        End With
    Else
        'nothing found, do nothing
    End If

End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
59,920
Office Version
  1. 365
Platform
  1. Windows
But the code is looking at cells in the range
VBA Code:
For Each rCell In srcRng.Columns(24).Cells
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

ToseSenpai

New Member
Joined
Apr 18, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Sorry for late reply.
The value to search is in the column X.
The macro search it in sheet "MEMO" and then copy the row (Only Columns 1-6) to sheet "ARCHIVIO RETTIFICHE".
 

ToseSenpai

New Member
Joined
Apr 18, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Try this:
This assumes you do have some data in Range("A1") of sheet named "ARCHIVIO RETTIFICHE"
VBA Code:
Sub Copy_Partial_Row()
'Modified  4/18/2021  8:56:40 AM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("MEMO").Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets("ARCHIVIO RETTIFICHE").Cells(Rows.Count, "A").End(xlUp).Row + 1

For i = 1 To Lastrow
    If Cells(i, 1).Value = "R" Then
        Cells(i, 1).Resize(, 6).Copy Sheets("ARCHIVIO RETTIFICHE").Cells(Lastrowa, 1)
        Lastrowa = Lastrowa + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

[/CODE
[/QUOTE]
Thank you. 
This work very well!
 

ToseSenpai

New Member
Joined
Apr 18, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Or use this:
This is a filter script which may be faster:
VBA Code:
Sub Filter_Me_Please()
'Modified  4/18/2021  10:07:54 AM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim lastrowa As Long
Dim c As Long
Dim s As Variant
c = 1 ' Column Number Modify this to your need
s = "R" 'Search Value Modify to your need
lastrow = Sheets("MEMO").Cells(Rows.Count, c).End(xlUp).Row
lastrowa = Sheets("ARCHIVIO RETTIFICHE").Cells(Rows.Count, c).End(xlUp).Row + 1

With Sheets("MEMO").Cells(1, c).Resize(lastrow, 6)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("ARCHIVIO RETTIFICHE").Cells(lastrowa, 1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub
How can i modify this for search "R" in column x?
 

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
17,669
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Well lets try this:
VBA Code:
Sub Filter_Me_Please()
'Modified  4/19/2021  1:28:04 AM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim lastrowa As Long
Dim c As Long
Dim s As Variant
c = 24 ' Column Number Modify this to your need
s = "R" 'Search Value Modify to your need
lastrow = Sheets("MEMO").Cells(Rows.Count, c).End(xlUp).Row
lastrowa = Sheets("ARCHIVIO RETTIFICHE").Cells(Rows.Count, c).End(xlUp).Row + 1

With Sheets("MEMO").Cells(1, c).Resize(lastrow, 6)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1, -23).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("ARCHIVIO RETTIFICHE").Cells(lastrowa, 1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub
 

ToseSenpai

New Member
Joined
Apr 18, 2021
Messages
7
Office Version
  1. 365
Platform
  1. Windows
Well lets try this:
VBA Code:
Sub Filter_Me_Please()
'Modified  4/19/2021  1:28:04 AM  EDT
Application.ScreenUpdating = False
Dim lastrow As Long
Dim lastrowa As Long
Dim c As Long
Dim s As Variant
c = 24 ' Column Number Modify this to your need
s = "R" 'Search Value Modify to your need
lastrow = Sheets("MEMO").Cells(Rows.Count, c).End(xlUp).Row
lastrowa = Sheets("ARCHIVIO RETTIFICHE").Cells(Rows.Count, c).End(xlUp).Row + 1

With Sheets("MEMO").Cells(1, c).Resize(lastrow, 6)
    .AutoFilter 1, s
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
        .Offset(1, -23).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("ARCHIVIO RETTIFICHE").Cells(lastrowa, 1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub
It's still have problem when paste to second sheet, nvm i will use the other vba macro that you post.
Thank you very much.

:):)
 

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
17,669
Office Version
  1. 2013
Platform
  1. Windows
It's still have problem when paste to second sheet, nvm i will use the other vba macro that you post.
Thank you very much.

:):)
What is the problem?

What is:nvm

When I posted my original post I thought we were looking for R in column A
But then you said column X
So not sure how my original post will work.
 
Last edited:

Forum statistics

Threads
1,136,303
Messages
5,674,967
Members
419,537
Latest member
ucatchy

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top