Solved

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

Posted on 2012-03-15
4
281 Views
Last Modified: 2012-03-15
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.
0
Comment
Question by:mato01
  • 2
  • 2
4 Comments
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 37727454
You can try this. You will have to assign appropriate sheet names to sws and tws
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37727504
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
 
LVL 43

Assisted Solution

by:Saqib Husain, Syed
Saqib Husain, Syed earned 250 total points
ID: 37727506
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
 
LVL 41

Accepted Solution

by:
dlmille earned 250 total points
ID: 37727513
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

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Sparklines have been introduced with Excel 2010 and are a useful tool for creating small in-cell charts, used for example in dashboards. Excel 2010 offers three different types of Sparklines: Line, Column and Win/Loss. What it does not offer is a…
Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.

863 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

26 Experts available now in Live!

Get 1:1 Help Now