Copy rows based on value in cell to first available empty row.

I have a spreadsheet with Columns A thru L.  I need to copy rows if the value in Column C is equal to Brown into the first empty cells at the end of the spreadsheet.
mato01Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Saqib Husain, SyedEngineerCommented:
You can try this. You will have to assign appropriate sheet names to sws and tws
0
dlmilleCommented:
If you want to copy those rows to the bottom of the existing sheet, use the first sub copyRows().  Otherwise, if you want a new worksheet created and the rows with A:L data and C column is blank, then use the sub copyRowsNewWorksheet()

The app works on the active sheet of the active workbook.  Finds cells with blanks in column c then copys that row range A:L to the bottom of the worksheet, or appends to a new sheet, depending on routine selected.

Option Explicit

Sub copyRows()
Dim wkb As Workbook
Dim wks As Worksheet
Dim r As Range
Dim rng As Range
Dim lastRow As Long
Dim i As Long

    Application.ScreenUpdating = False
    
    Set wkb = ActiveWorkbook
    Set wks = wkb.ActiveSheet
    
    lastRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row
    Set rng = wks.Range("C1:C" & lastRow)
    For Each r In rng.SpecialCells(xlCellTypeBlanks)
        wks.Range("A" & r.Row & ":L" & r.Row).Copy 'copy A:L on blank cell column C to bottom of existing worksheet
        wks.Range("A" & lastRow + i + 1).PasteSpecial
        Application.CutCopyMode = False
        i = i + 1

    Next r
        
    MsgBox "Process Complete"
    
    Application.ScreenUpdating = True
End Sub
Sub copyRowsNewWorksheet()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksOut As Worksheet
Dim r As Range
Dim rng As Range
Dim lastRow As Long
Dim i As Long

    Application.ScreenUpdating = False
    
    Set wkb = ActiveWorkbook
    Set wks = wkb.ActiveSheet
    Set wksOut = wkb.Worksheets.Add(after:=wkb.Worksheets(wks.Name))
    
    lastRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row
    Set rng = wks.Range("C1:C" & lastRow)
    For Each r In rng.SpecialCells(xlCellTypeBlanks)
        wks.Range("A" & r.Row & ":L" & r.Row).Copy 'copy A:L on blank cell column C to bottom of existing worksheet
        wksOut.Range("A" & i + 1).PasteSpecial
        Application.CutCopyMode = False
        i = i + 1
    Next r
        
    MsgBox "Process Complete"
    
    Application.ScreenUpdating = True
End Sub

Open in new window


see attached demonstration workbook.

Dave
copyrows-r1.xls
0
Saqib Husain, SyedEngineerCommented:
Oops...no macro attached

Sub a()
Dim lr As Long, cel As Range, tws As Worksheet, Sws As Worksheet
Set Sws = Sheets("Sheet3")
Set tws = Sheets("Sheet1")
lr = Sws.Cells.Find("*", Range("A1"), , , , xlPrevious).Row + 1
For Each cel In Sws.Range("C1:C" & lr)
If cel.Value = "Brown" Then
cel.Offset(0, -2).Resize(1, 12).Copy tws.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next cel
End Sub
0
dlmilleCommented:
Looks like my post prompted you, and then yours prompted me!

not blank cells, cells having BROWN!

Here's my repost:
Option Explicit

Sub copyRows()
Dim wkb As Workbook
Dim wks As Worksheet
Dim r As Range
Dim rng As Range
Dim lastRow As Long
Dim i As Long

    Application.ScreenUpdating = False
    
    Set wkb = ActiveWorkbook
    Set wks = wkb.ActiveSheet
    
    lastRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row
    Set rng = wks.Range("C1:C" & lastRow)
    For Each r In rng
        If UCase(r.Value) = "BROWN" Then
            wks.Range("A" & r.Row & ":L" & r.Row).Copy 'copy A:L on blank cell column C to bottom of existing worksheet
            wks.Range("A" & lastRow + i + 1).PasteSpecial
            Application.CutCopyMode = False
            i = i + 1
        End If

    Next r
        
    MsgBox "Process Complete"
    
    Application.ScreenUpdating = True
End Sub
Sub copyRowsNewWorksheet()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksOut As Worksheet
Dim r As Range
Dim rng As Range
Dim lastRow As Long
Dim i As Long

    Application.ScreenUpdating = False
    
    Set wkb = ActiveWorkbook
    Set wks = wkb.ActiveSheet
    Set wksOut = wkb.Worksheets.Add(after:=wkb.Worksheets(wks.Name))
    
    lastRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row
    Set rng = wks.Range("C1:C" & lastRow)
    For Each r In rng
        If UCase(r.Value) = "BROWN" Then
            wks.Range("A" & r.Row & ":L" & r.Row).Copy 'copy A:L on blank cell column C to bottom of existing worksheet
            wksOut.Range("A" & i + 1).PasteSpecial
            Application.CutCopyMode = False
            i = i + 1
        End If
    Next r
        
    MsgBox "Process Complete"
    
    Application.ScreenUpdating = True
End Sub

Open in new window


Attached find demo.  Should be a collaborative effort, lol.

Dave
copyrows-r2.xls
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.