Need a macro

Lavan

Board Regular
Joined
Dec 15, 2004
Messages
56
Hello Experts,

I need a macro to move the entire row to next sheet if the value in column A matches.. For example my data is like below . If any cell value in column A matches to "a", I want that entire row to be moved to sheet2. So all the rows with cell value "a" in column A, should be moved to sheet2 after I run the macro.

Thanks in advance,
Lavan


a 1 1
b 2 3
a 4 4
b 2 1
c 3 3
d 14 4
a 3 4
a 1 3
f 1 1
f 2 2
a 5 5
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

facethegod

Well-known Member
Joined
Aug 1, 2006
Messages
767
if your data is in Columns A,B,C try this macro

Code:
Public Sub Copyvalue()
Dim Lrow, i, j, x As Integer
x = 1
Lrow = Range("A65535").End(xlUp).Row
For i = 1 To Lrow
    If Cells(i, 1) = "a" Then
            With Range("B" & i).Resize(, 2)
                While Worksheets(2).Cells(x, 1) <> ""
                    x = x + 1
                Wend
                .Copy Destination:=Worksheets(2).Range("A" & x)
            End With
    End If
Next
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
57,446
Office Version
  1. 365
Platform
  1. Windows
Lavan

Welcome to the MrExcel board!

If you have a lot of rows of data, the following code that avoids the looping may be quicker. In any case, it is another option to consider. The code assumes that there are no headings on the columns in Sheet1. If that assumption is incorrect, then a slight modification could be made to the code and that modification would depend on wheteher you wanted the headings copied across to Sheet2 as well.

My other assumption is that Sheet1 will be the active sheet when the code is run. Again, modifications can be made if this is not correct.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> CopyRows()
    <SPAN style="color:#00007F">Dim</SPAN> lr <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    
    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN>
    Rows(1).EntireRow.Insert
    lr = Range("A" & Rows.Count).End(xlUp).Row
    <SPAN style="color:#00007F">With</SPAN> Range("A1:A" & lr)
        .AutoFilter Field:=1, Criteria1:="a"
        .Resize(.Rows.Count - 1, 3).Offset(1).Copy _
            Destination:=Sheets("Sheet2").Range("A1")
        .AutoFilter
    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>
    Rows(1).EntireRow.Delete
    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 

Lavan

Board Regular
Joined
Dec 15, 2004
Messages
56
Peter, Thanks a milllion. Its very very fast and exact match to my requirement. Thanks again.

Lavan
 

Lavan

Board Regular
Joined
Dec 15, 2004
Messages
56
Peter,

I have modified your code according to my requirement to move the data to different sheets as below. The problem is my data is not same always, so code is returning error if the data I am trying to move to a sheet is not available. Below is the code I am using, for example if the value "FA-3A Port 0" is not available, it returning the error. Please let me know how to proceed to next even if some of the search valumes not existing in data.

Thanks in Advance,


Sub CopyRows_new()
Dim lr As Long

'Application.ScreenUpdating = False

Sheets.Add.Name = "FA-3A Port 0"
Sheets.Add.Name = "FA-3A Port 1"
Sheets.Add.Name = "FA-3B Port 0"
Sheets.Add.Name = "FA-3B Port 1"
Sheets.Add.Name = "FA-3C Port 0"
Sheets.Add.Name = "FA-3C Port 1"


Rows(1).EntireRow.Insert
lr = Range("A" & Rows.Count).End(xlUp).Row
With Range("A1:A" & lr)
.AutoFilter Field:=1, Criteria1:="FA-3A Port 0"
.Resize(.Rows.Count - 1, 8).Offset(1).Copy _
Destination:=Sheets("FA-3A Port 0").Range("A1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="FA-3A Port 1"
.Resize(.Rows.Count - 1, 8).Offset(1).Copy _
Destination:=Sheets("FA-3A Port 1").Range("A1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="FA-3B Port 0"
.Resize(.Rows.Count - 1, 8).Offset(1).Copy _
Destination:=Sheets("FA-3B Port 0").Range("A1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="FA-3B Port 1"
.Resize(.Rows.Count - 1, 8).Offset(1).Copy _
Destination:=Sheets("FA-3B Port 1").Range("A1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="FA-3C Port 0"
.Resize(.Rows.Count - 1, 8).Offset(1).Copy _
Destination:=Sheets("FA-3C Port 0").Range("A1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="FA-3C Port 1"
.Resize(.Rows.Count - 1, 8).Offset(1).Copy _
Destination:=Sheets("FA-3C Port 1").Range("A1")
.AutoFilter


End With
Rows(1).EntireRow.Delete
Sheets("masking").Select
Application.ScreenUpdating = True
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
57,446
Office Version
  1. 365
Platform
  1. Windows
Lavan

I haven't actually run a test but I think this should solve your problem. change the filter and copy part as follows:

With Range("A1:A" & lr)
On Error Resume Next
.
.
rest of the filter/copy code here
.
.
On Error GoTo 0
End With
 

Lavan

Board Regular
Joined
Dec 15, 2004
Messages
56
Peter,

I have used below code, now error returning is stopped. But its returning the data of the 1st sheet to all the sheets where data is not available. With respect to below code, I dont have data available in my spread sheet for all FA-10XPort1 sheets, I have data available only for FA-10XPort0, but code is retuning FA-10APort0 values to all the sheets of FA-10Xport1. As the data is not availble for any FA-10XPort1, All the sheets of FA-10Xport1 should be blank. Please help.

PS: FA-10XPort1 refers to FA-10APort1, FA-10BPort1 etc

thanks in advance,
Lavan


Sub CopyRows_new()
Dim lr As Long

Application.ScreenUpdating = False


Sheets.Add.Name = "FA-10APort0"
Sheets.Add.Name = "FA-10APort1"
Sheets.Add.Name = "FA-10BPort0"
Sheets.Add.Name = "FA-10BPort1"
Sheets.Add.Name = "FA-10CPort0"
Sheets.Add.Name = "FA-10CPort1"
Sheets.Add.Name = "FA-10DPort0"
Sheets.Add.Name = "FA-10DPort1"


Rows(1).EntireRow.Insert
lr = Range("A" & Rows.Count).End(xlUp).Row
With Range("A1:A" & lr)
On Error Resume Next


.AutoFilter Field:=1, Criteria1:="FA-10APort0"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10APort0").Range("A1")
.AutoFilter

.AutoFilter Field:=1, Criteria1:="FA-10APort1"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10APort1").Range("A1")
.AutoFilter

.AutoFilter Field:=1, Criteria1:="FA-10BPort0"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10BPort0").Range("A1")
.AutoFilter

.AutoFilter Field:=1, Criteria1:="FA-10BPort1"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10BPort1").Range("A1")
.AutoFilter

.AutoFilter Field:=1, Criteria1:="FA-10CPort0"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10CPort0").Range("A1")
.AutoFilter

.AutoFilter Field:=1, Criteria1:="FA-10CPort1"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10CPort1").Range("A1")
.AutoFilter

.AutoFilter Field:=1, Criteria1:="FA-10DPort0"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10DPort0").Range("A1")
.AutoFilter

.AutoFilter Field:=1, Criteria1:="FA-10DPort1"
.Resize(.Rows.Count - 1, 10).Offset(1).Copy _
Destination:=Sheets("FA-10DPort1").Range("A1")
.AutoFilter

On Error GoTo 0
End With
Rows(1).EntireRow.Delete
Sheets("masking").Select
Application.ScreenUpdating = True
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
57,446
Office Version
  1. 365
Platform
  1. Windows
I am not sur I understand all that but try this:
Just below all the
Sheets.Add.Name...
rows, put
Sheets("masking").Activate
only replace "masking" if it is not the sheet with all the info on to start with.
 

Forum statistics

Threads
1,181,724
Messages
5,931,688
Members
436,798
Latest member
spprtpplcm

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