Copy rows from one sheet to another based on a list

[ajilthomas]

Hi

I am trying to create a macro which would copy the entire row of data from one sheet based on the a list of values in another sheet, additionally it should remove any rows which might have the value of not required. The sheet 1 will have the below values :-

[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64"]abb[/TD]
[/TR]
[TR]
[TD]bcd[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
The sheet 2 would be having having data in the following format :-

[TABLE="width: 192"]
<tbody>[TR]
[TD="width: 64"]Name[/TD]
[TD="width: 64"]Status[/TD]
[TD="width: 64"]location[/TD]
[/TR]
[TR]
[TD]abb[/TD]
[TD]Not Required[/TD]
[TD]new york[/TD]
[/TR]
[TR]
[TD]abb[/TD]
[TD][/TD]
[TD]france[/TD]
[/TR]
[TR]
[TD]bcd[/TD]
[TD][/TD]
[TD]france[/TD]
[/TR]
[TR]
[TD]bcd[/TD]
[TD][/TD]
[TD]france[/TD]
[/TR]
[TR]
[TD]fgh[/TD]
[TD][/TD]
[TD]france[/TD]
[/TR]
[TR]
[TD]ty[/TD]
[TD][/TD]
[TD]france[/TD]
[/TR]
[TR]
[TD]hu[/TD]
[TD][/TD]
[TD]germany[/TD]
[/TR]
[TR]
[TD]ty[/TD]
[TD]Not Required[/TD]
[TD]germany[/TD]
[/TR]
[TR]
[TD]fgh[/TD]
[TD][/TD]
[TD]germany[/TD]
[/TR]
[TR]
[TD]op[/TD]
[TD][/TD]
[TD]germany[/TD]
[/TR]
[TR]
[TD]er[/TD]
[TD][/TD]
[TD]germany
[/TD]
[/TR]
</tbody>[/TABLE]
The final data would look something like below

abb <space> France
bcd <space> France
bcd <space> France


Have been able to use something like below :-

Sub MoveRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("CMDB").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("CMDB").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Done" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

however not able to replace "done" with the list, please help.

Thanks</space></space></space>

 

[Fluff]

Hi, could you please answer the following?
1) What is the sheet name & data range for the filter values?
2) What is the sheet name & data range for the values to be copied?
3) What is the sheet name where you want the data to be copied 2?
4) Do you want the sheet in point 3 cleared each time?

 

[ajilthomas]

Hi, could you please answer the following?
1) What is the sheet name & data range for the filter values?
2) What is the sheet name & data range for the values to be copied?
3) What is the sheet name where you want the data to be copied 2?
4) Do you want the sheet in point 3 cleared each time?

Hello Fluff,

Thanks for your reply, my replies

1) What is the sheet name & data range for the filter values? - we can call it sheet 1, data range is single column
2) What is the sheet name & data range for the values to be copied? the Sheet name is called sheet 2, range would be columns A:C, therefore each row against the value
3) What is the sheet name where you want the data to be copied 2? this can be called sheet 3 starting from Cell A2 - C2
4) Do you want the sheet in point 3 cleared each time? nope just copy.

Thanks again for the reply

 

[Fluff]

How about

Sub CopyFltr()

    Dim Ary As Variant
    Dim UsdRws As Long
    
    Ary = Application.Transpose(Sheets("Sheet1").Range("A1").CurrentRegion)
    With Sheets("Sheet2")
        If .AutoFilterMode Then .AutoFilterMode = False
        UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1").AutoFilter 1, Ary, xlFilterValues
        .Range("A1").AutoFilter 2, ""
        .Range("A2:C" & UsdRws).SpecialCells(xlVisible).copy Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .AutoFilterMode = False
    End With
    
End Sub

 

[ajilthomas]

How about

Sub CopyFltr()

    Dim Ary As Variant
    Dim UsdRws As Long
    
    Ary = Application.Transpose(Sheets("Sheet1").Range("A1").CurrentRegion)
    With Sheets("Sheet2")
        If .AutoFilterMode Then .AutoFilterMode = False
        UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1").AutoFilter 1, Ary, xlFilterValues
        .Range("A1").AutoFilter 2, ""
        .Range("A2:C" & UsdRws).SpecialCells(xlVisible).copy Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .AutoFilterMode = False
    End With
    
End Sub

Hi

getting an error on line <.Range("A2:C" & UsdRws).SpecialCells(xlVisible).Copy Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)>

Is there any way i can the worksheet here with the macro till now? Thanks

 

[Fluff]

When you get the error, are there any visible cells on sheet2, with the exception of the header row?

Is there any way i can the worksheet here with the macro till now? Thanks

I'm afraid I don't understand what you mean by this.

 

[ajilthomas]

Its giving an error no cells were found, the macro i am using now.

Sub MoveRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Sheet2").UsedRange.Rows.Count
J = Worksheets("Sheet3").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet3").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet2").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "MNO" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet3").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

hope this helps

 

[ajilthomas]

No, the cells are getting filtered with no visible cells. Sorry i meant is there any way i can upload the worksheet here with the macro. Thanks

 

[Fluff]

Have you actually tried the macro I supplied in post#4?

You cannot upload a file to this site. But you can upload to OneDrive or dropbox. mark it as shared 7 then paste a link here.

 

[ajilthomas]

Have you actually tried the macro I supplied in post#4?

You cannot upload a file to this site. But you can upload to OneDrive or dropbox. mark it as shared 7 then paste a link here.

Hi Fluff,

yes, i did check with the code you send it then gives the error, anyway i have now uploaded the original excel and macro and the new one with your macro. Hope this is easier.

https://1drv.ms/f/s!AkEflwWNrzmfeLIH0JmCdd9PWXw