VBA code to copy rows in range - if cells in first column are not blank

GreenMan37

New Member
Joined
Jun 30, 2017
Messages
4
Hi folks,

I'm trying to perform a function that is probably a walk in the park for many of you but it's causing me all manner of grief.
Here's my scenario and I really hope someone is able to assist with a useful code solution.

I have a specific range (C14:AE78) but only some of the rows in that range will be populated. Within the actual row, there will also be blanks in cells in some columns. What I would like to do is copy only those rows within the stated range that have values in Column C. In other words, if cells in column C (rows 14:78) are populated, then the entire row (going out to column AE) will need to be copied.

I've attempted a range of codes but they're not quite right. For example, I've tried the following based on my attempt to record a macro, but when I add a new row of data to the range and run the code again, it doesn't select the new row.

Sub Activity_copy()
Range("C14").Select​
Selection.End(xlDown).Select​
Range(Selection, Selection.End(xlUp)).Select​
Range("C14:AE28").Select​
Range("C28").Activate​
Selection.Copy​
End Sub​

I've regularly adapted codes that I've found online and they've been fine but I cannot seem to find this scenario and a subsequent resolution.

Any assistance or code solutions would be greatly appreciated.

Thanks!
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Hello and welcome.


I've just tested this and it seems to fit what you ask, you just need to change WHERE the code is pasted to as you don't mention that.


Code:
Sub CopyRange()

    Dim rToCopy As Range
    Dim i As Integer
    
    For i = 14 To 78
        If Not IsEmpty(Range("C" & i)) Then
            If rToCopy Is Nothing Then
                Set rToCopy = Range("C" & i & ":AE" & i)
            Else
                Set rToCopy = Union(rToCopy, Range("C" & i & ":AE" & i))
            End If
        End If
    Next i
    
    rToCopy.Copy
    Range("CHANGEME").PasteSpecial xlPasteAll 'Change this line to include paste range  
 
End Sub
 
Last edited:
Upvote 0
Hello Gallen and thankyou for your efforts. I do appreciate the prompt response.

There are some additional challenges at play here, as follows:

Firstly, the code seems to copy ALL the cells in the range (C14:AE78), rather than just the rows that have data (e.g. the first 20 rows).

Secondly, the destination for the copied cells is a sheet within another workbook. That sheet will be used to consolidate a heap of records (similar to those found on the source document) and will continue to be added to each month. As such, I'll always need to add the new data to the next available row and I've built a macro-enabled button in that sheet that will take me straight to the next available row.

The basic idea of all this is that different users will be issued with a template (the source worksheet) to record activity. Different users will obviously report different levels and types of activity (so there'll be variation across the range - some cells in the row will be blank, others will be populated) so the row count will vary for each. It's my intention that only non-blank rows are copied so no blank rows are picked up.

An administrator (or me, initially) will then need to grab all the non-blank rows from the C14:AE78 range within each template and paste them into a consolidated worksheet of a dashboard-styled workbook (which has pivots that feed off the consolidated data worksheet).

It would've been fairly easy to devise a code that selected the entire possible range (C14:AE78) but I don't want the blanks. And, at this stage, I only want to copy the data, not paste it anywhere - not automatically, anyway. That's why I reached out for help here. :) Maybe in future, I'll look at making that change and automating the process so it grabs all non-blank rows and pastes them into the next available row of the destination workbook...but not yet.

Does that help explain things better?

Thanks!
 
Upvote 0
Hello again folks. I wasn't able to resolve the challenge outlined above. Gallen had a crack at it but it didn't quite resolve the issue. Any other takers?
 
Upvote 0
I've tested this and it doesn't copy ALL the cells. If you read the code:


  1. Loop through all rows from 14 to 78
  2. If Column C of that row contains a value then copy C to AE
  3. Copy all cells
  4. Paste all values to a specific range.

I've tested on a range within the same workbook, only had 5 rows with values between C14:AE78 and it just pasted 5 rows to Cell A1 of a different sheet within the same workbook.

How does your data look?
 
Last edited:
Upvote 0
Finally, in response to your additional parameters, this code will open a specific workbook and paste the info to a specific cell on a specific worksheet. You will need to change the code to reflect each item. All lines that need changing are highlighted and commented

I have tested this and it works how you ask, pasting to the next available row

Code:
Sub CopyRange()

    Dim rToCopy As Range
    Dim i As Integer
    Dim sPath As String 'Path of workbook to paste to
    Dim sWbName As String 'Name of Workbook to paste to
    Dim sWsName As String 'Name of worksheet to paste to
    Dim nr As Long 'Next row to paste to
    
    Dim wbPaste As Workbook
    Dim wsPaste As Worksheet
    
    sPath = "[B][COLOR=#ff0000]C:\Test\[/COLOR][/B]" ' *** Path location of Workbook to paste to. Note the ending backslash '\'
    sWbName = "[B][COLOR=#ff0000]Data.xlsx[/COLOR][/B]" ' *** Change to your file name
    sWsName = "[COLOR=#ff0000][B]Data[/B][/COLOR]" ' *** Change to your sheet name
    
    '=============This section tries to get the work book you wish to paste to================
    'Firstly check if workbook is open
    On Error Resume Next 'Ignore errors
    Set wbPaste = Workbooks(sWbName)
    
    'If wbPaste is nothing then it wasn't open so now open it
    If wbPaste Is Nothing Then
        Set wbPaste = Workbooks.Open(sPath & sWbName)
    End If
    
    'If wbPaste is nothing now, then it doesn't exist in the specified location
    If wbPaste Is Nothing Then
        MsgBox "Can not find " & sPath & sWbName & ". Please check the file exists and try again", vbExclamation, "File Not Found"
        Exit Sub
    End If
    '==========================================================================================
    
    'If we get here then the file exists and is open
    
    'Set the worksheet variable
    Set wsPaste = wbPaste.Sheets(sWsName)
    
    If wsPaste Is Nothing Then 'Worksheet not found
        MsgBox "Can not find a sheet named " & sWsName & ". Please check the sheet exists and try again", vbExclamation, "File Not Found"
        Exit Sub
    End If
    
    On Error GoTo 0 'Don't ignore errors
    
    '=============================================================================================
    
    'Finally if we get here, we have the sheet and the workbook
    
    'loop through all rows from 14 to 78
    For i = 14 To 78
        'if column c of the specific row has a value then add it to our range to copy.
        If Not IsEmpty(Range("C" & i)) Then
            If rToCopy Is Nothing Then
                'if no lines added to our copy range then just add the range
                Set rToCopy = Range("C" & i & ":AE" & i)
            Else
                'If range to copy has a value then apend the range
                Set rToCopy = Union(rToCopy, Range("C" & i & ":AE" & i))
            End If
        End If
    Next i
    
    rToCopy.Copy
    
    'Get next blank row to paste to
    nr = wsPaste.Range("A" & Rows.Count).End(xlUp).Row + 1


    'Paste to column A of the next blank row. Change if different column
    wsPaste.Range("[COLOR=#ff0000][B]A[/B][/COLOR]" & nr).PasteSpecial xlPasteAll
    
    'Tidy up
    
    Set wsPaste = Nothing
    Set wbPaste = Nothing
 
End Sub

If it is still copying the full range then check there are no invisible characters / whitespace in the 'blank cells'. This line checks if the cell is empty:
Code:
If Not IsEmpty(Range("C" & i)) Then
 
Upvote 0
Gallen, you are a superstar!

Yes, your original code worked fine, now that I've attempted it again without distractions. The reason I thought it wasn't working initially (besides not being clear of mind) was because each of the cells in column C had a formula which was based on values in column D. If they were blank, then the corresponding column C cells would be blank as well (""). Silly me forgot about the formulas in column C. Visually, they're blanks but that's not what is really happening, of course.

I'm so incredibly grateful for your efforts to produce a solution. I literally threw my hands in the air in relief when I saw the code working. Feelings of relief, joy, satisfaction....and an overwhelming need to thank you as soon as possible came across me.

Brilliant work. Thanks again.
 
Upvote 0
Very welcome. Good to see you worked out the issue for yourself. Best way of learning.
 
Upvote 0
Very welcome. Good to see you worked out the issue for yourself. Best way of learning.

Hey Gallen!

Sorry to dig up an old thread, but I've been using your code as a starting point for something I am trying to achieve.

This is currently what I have:

Code:
Sub dedfsdf()

Dim rToCopy As Range
Dim rToCopyCol As Range
Dim rFinalCopy As Range
Dim CCol As String
Dim ProjectCol As String
Dim VendorCol As String
Dim DescCol As String
Dim POCol As String
Dim CurrencyCol As String
Dim i As Long
Dim StartCol As String
Dim EndCol As String


Application.ScreenUpdating = False


Worksheets("Salesforce").Activate
Worksheets("Salesforce").Range("A1").Select


StartCol = Worksheets("Expense Report").Cells(8, 18).Value 'R8
EndCol = Worksheets("Expense Report").Cells(8, 19).Value 'S8
CCCol = Worksheets("Salesforce").Cells("B").Value
ProjectCol = Worksheets("Salesforce").Cells("F").Value
VendorCol = Worksheets("Salesforce").Cells("N").Value
DescCol = Worksheets("Salesforce").Cells("O").Value
POCol = Worksheets("Salesforce").Cells("Q").Value
CurrencyCol = Worksheets("Salesforce").Cells("S").Value
LastRow = Worksheets("Salesforce").Cells(Rows.Count, 1).End(xlUp).Row


    For i = 2 To LastRow
        If Not IsEmpty(Range(StartCol & i, EndCol & i)) Then
            If rToCopy Is Nothing Then
                Set rToCopy = Range(StartCol & i, EndCol & i)
            Else
                Set rToCopyCol = Union(CCCol & i, ProjectCol & i, VendorCol & i, DescCol & i, POCol & i, CurrencyCol & i)
                Set rToCopy = Union(rToCopyCol, rToCopy, Range(StartCol & i, EndCol & i))
            End If
        End If
    Next i
    
    rToCopy.Copy
    Worksheets("Expense Report").Cells(16, 24).PasteSpecial xlPasteAll


Application.ScreenUpdating = True


End Sub

In one sheet (Salesforce) I have a bunch of columns with Month Headers (Apr-17 etc).
On another sheet (Expense Report) I have an user drop box where they select two months (IE. apr-17 to dec-17). My goal with the macro is for it to scan through the user input columns and look for records that are not empty. It should then extract all of these records to the expense report.

I was able to get the functionality to the point where it would extract the data correctly for the two month ranges, but I need to be able to also pull the adjacent rows (to the left) of the two specified columns). I seem to be getting a mismatch error whenever I try to run my code. Sorry if I am not being very clear.
 
Upvote 0
I've read your code and it is very confusing.

Compare my original code with your code. I've commented each line explaining what it does.


You say here:

I need to be able to also pull the adjacent rows (to the left) of the two specified columns)

I Assume you mean the 2 columns?

This code doesn't make sense. If you write a comment in plain English, what you expect each line to achieve then it will help me help you.

Code:
[COLOR=#574123]            If rToCopy Is Nothing Then
[/COLOR]                Set rToCopy = Range(StartCol & i, EndCol & i)
            Else
                Set rToCopyCol = Union(CCCol & i, ProjectCol & i, VendorCol & i, DescCol & i, POCol & i, CurrencyCol & i)
                Set rToCopy = Union(rToCopyCol, rToCopy, Range(StartCol & i, EndCol & i))
 [COLOR=#574123]           End If[/COLOR]
 
Upvote 0

Forum statistics

Threads
1,213,563
Messages
6,114,332
Members
448,566
Latest member
Nickdozaj

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