VBA code for copying row to another sheet depending on column value.

A

Arpit1

New Member
Joined
Mar 17, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hello,
I would like to have a VBA code for copying the complete rows of one sheet into another depending on the column value of the primary sheet. The column values would be YES or NO and depending on YES, I need to copy those complete rows into another sheet.
The first sheet name is 'AS ELBIA' and the second sheet name is 'RED FLAG'. There are 16 columns involved and the dependent value YES or NO will be in the 16th column i .e. column P.
Please help me out.
Thank you.
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Try:
VBA Code: 
Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("AS ELBIA")
    Set desWS = Sheets("RED FLAG")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter 16, "Yes"
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
Try:
VBA Code: 
Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("AS ELBIA")
    Set desWS = Sheets("RED FLAG")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS
        .Range("A1").CurrentRegion.AutoFilter 16, "Yes"
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub
Click to expand...
I am getting an error being subscript out of range.
 
Upvote 0
Am getting a Run-Time error '1004': Application-defined or object-defined error
 
Upvote 0
VBA Code: 
Sub copyRow()
  Dim rLastRow As Long, i As Long, j As Long, m As Long
  Dim arr, brr
  Dim sourceSht As String, targetSht As String

  sourceSht = "AS ELBIA"
  targetSht = "RED FLAG"
  With Worksheets(sourceSht)
    rLastRow = .Cells(.Rows.Count, "P").End(xlUp).Row
    arr = .Range("A2:P" & rLastRow)
   
    ReDim brr(1 To UBound(arr), 1 To 16)
    m = 0
    For i = 1 To UBound(arr)
      If UCase(arr(i, 16)) = "YES" Then
        m = m + 1
        For j = 1 To 16
            brr(m, j) = arr(i, j)
        Next
      End If
    Next
  End With
  With Worksheets(targetSht)
    .UsedRange.Offset(1, 0).Clear
    .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
  End With
End Sub

工作簿1.xlsm
ABCDEFGHIJKLMNOP
1Title1Title2Title3Title4Title5Title6Title7Title8Title9Title10Title11Title12Title13Title14Title15Title16
2123456789101112131415NO
32345678910111213141516NO
434567891011121314151617YES
5456789101112131415161718NO
65678910111213141516171819NO
767891011121314151617181920NO
8789101112131415161718192021NO
98910111213141516171819202122NO
1091011121314151617181920212223NO
11101112131415161718192021222324YES
12111213141516171819202122232425NO
13121314151617181920212223242526NO
14131415161718192021222324252627NO
15141516171819202122232425262728NO
16151617181920212223242526272829YES
17161718192021222324252627282930NO
18171819202122232425262728293031NO
19181920212223242526272829303132YES
20192021222324252627282930313233NO
AS ELBIA


工作簿1.xlsm
ABCDEFGHIJKLMNOP
1Title1Title2Title3Title4Title5Title6Title7Title8Title9Title10Title11Title12Title13Title14Title15Title16
234567891011121314151617YES
3101112131415161718192021222324YES
4151617181920212223242526272829YES
5181920212223242526272829303132YES
RED FLAG
 
Upvote 0
Solution
Lian said:
VBA Code: 
Sub copyRow()
  Dim rLastRow As Long, i As Long, j As Long, m As Long
  Dim arr, brr
  Dim sourceSht As String, targetSht As String

  sourceSht = "AS ELBIA"
  targetSht = "RED FLAG"
  With Worksheets(sourceSht)
    rLastRow = .Cells(.Rows.Count, "P").End(xlUp).Row
    arr = .Range("A2:P" & rLastRow)
  
    ReDim brr(1 To UBound(arr), 1 To 16)
    m = 0
    For i = 1 To UBound(arr)
      If UCase(arr(i, 16)) = "YES" Then
        m = m + 1
        For j = 1 To 16
            brr(m, j) = arr(i, j)
        Next
      End If
    Next
  End With
  With Worksheets(targetSht)
    .UsedRange.Offset(1, 0).Clear
    .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
  End With
End Sub

工作簿1.xlsm
ABCDEFGHIJKLMNOP
1Title1Title2Title3Title4Title5Title6Title7Title8Title9Title10Title11Title12Title13Title14Title15Title16
2123456789101112131415NO
32345678910111213141516NO
434567891011121314151617YES
5456789101112131415161718NO
65678910111213141516171819NO
767891011121314151617181920NO
8789101112131415161718192021NO
98910111213141516171819202122NO
1091011121314151617181920212223NO
11101112131415161718192021222324YES
12111213141516171819202122232425NO
13121314151617181920212223242526NO
14131415161718192021222324252627NO
15141516171819202122232425262728NO
16151617181920212223242526272829YES
17161718192021222324252627282930NO
18171819202122232425262728293031NO
19181920212223242526272829303132YES
20192021222324252627282930313233NO
AS ELBIA


工作簿1.xlsm
ABCDEFGHIJKLMNOP
1Title1Title2Title3Title4Title5Title6Title7Title8Title9Title10Title11Title12Title13Title14Title15Title16
234567891011121314151617YES
3101112131415161718192021222324YES
4151617181920212223242526272829YES
5181920212223242526272829303132YES
RED FLAG
Click to expand...
Thank you so much Lian. It was really great. The code ran perfectly at first attempt.
 
Upvote 0
You must log in or register to reply here.

Similar threads

tabbytomo
  • Solved
Copy entire row if cell has specific value, looking at multiple columns and worksheets.
Replies
2
Views
293
NateSC
NateSC
Kaz09
  • Question
Copy rows of data from multiple worksheets to based on column equalling YES
Replies
0
Views
110
Kaz09
Kaz09
P
  • Question
Need VBA to automatically copy paste rows based on dates of current month.
2
Replies
11
Views
225
pk970
P
B
  • Solved
Another VBA question to hide/unhide rows based on cell value in another sheet
2
Replies
12
Views
437
kevin9999
K
B
  • Solved
VBA Help - Same Function needed for multiple sheets
Replies
2
Views
243
birdman15
B

Forum statistics

Threads
1,215,007
Messages
6,122,670
Members
449,091
Latest member
peppernaut

Share this page

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
Back
Top