VBA Copy NonBlanks from Range to other range

P

p.huddy

Board Regular
Joined
May 5, 2010
Messages
59
Hi,

I have looked at a few codes and tried to put them together (crudely admittedly) but have gone wrong so hoping someone could point out my error!

I have a sheet with a list of tab on in Range I2:I23 as it can vary. I want a code to check each tab on two ranges, C5:H79 & C86:H160 and copy any non blank cells into a different tab, Collection into relevant column B3:G377.

I got it working on one column but when I expanded it to check all columns & go through the Tab range it stopped working but I can't see where! :confused:

I know I could loop it more but this code is the hardest I have ever tried!

Any help would be grateful!

Code: 
Sub EndofDayBanking()    Dim strName As String
    Dim C As Range
    
    Set C1 = Sheets("Collection").Range("B3")
    Set C2 = Sheets("Collection").Range("C3")
    Set C3 = Sheets("Collection").Range("D3")
    Set C4 = Sheets("Collection").Range("E3")
    Set C5 = Sheets("Collection").Range("F3")
    Set C6 = Sheets("Collection").Range("G3")
    
    For i = 2 To 23


strName = Range("I" & i)
On Error Resume Next
    Sheets(strName).Range ("C5:C79")
        If Len(C.Value) > 0 Then
            C.Copy
            C1.PasteSpecial Paste:=xlPasteValues
            Set C1 = C1.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("C86:C160").ClearContents
            If Len(C.Value) > 0 Then
            C.Copy
            C1.PasteSpecial Paste:=xlPasteValues
            Set C1 = C1.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("D5:D79").ClearContents
            If Len(C.Value) > 0 Then
            C.Copy
            C2.PasteSpecial Paste:=xlPasteValues
            Set C2 = C2.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("D86:D160").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C2.PasteSpecial Paste:=xlPasteValues
            Set C2 = C2.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("E5:E79").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C3.PasteSpecial Paste:=xlPasteValues
            Set C3 = C3.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("E86:E160").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C3.PasteSpecial Paste:=xlPasteValues
            Set C3 = C3.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("F5:F79").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C4.PasteSpecial Paste:=xlPasteValues
            Set C4 = C4.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("F86:F160").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C4.PasteSpecial Paste:=xlPasteValues
            Set C4 = C4.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("G5:G79").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C5.PasteSpecial Paste:=xlPasteValues
            Set C5 = C5.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("G86:G160").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C5.PasteSpecial Paste:=xlPasteValues
            Set C5 = C5.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("H5:H79").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C6.PasteSpecial Paste:=xlPasteValues
            Set C6 = C6.Offset(1, 0) '//advance to next cell below
        End If
    Sheets(strName).Range("H86:H160").ClearContents
        If Len(C.Value) > 0 Then
            C.Copy
            C6.PasteSpecial Paste:=xlPasteValues
            Set C6 = C6.Offset(1, 0) '//advance to next cell below
        End If
    Next i
    
    Application.CutCopyMode = False


End Sub

Thanks for any help in advance!
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
What are you trying to Copy? When I run your code I get the following

Code: 
'C.Value = <0bject Variable or With Block Variable not set>"

so it is not coping anything. What is suppose to be getting copied from inside the range set by Sheets(strName).Range ("C5:C79")?
 
Last edited:
Upvote 0
Also, looking through your code I am confused...

Why are you clearing the contents of a range, then trying to copy something??

Code: 
Sheets(strName).Range("C86:C160").ClearContents            If Len(C.Value) > 0 Then
            C.Copy 'What range is this coping if you just cleared C86 - C160?
            C1.PasteSpecial Paste:=xlPasteValues
            Set C1 = C1.Offset(1, 0) '//advance to next cell below
        End If

This will just add a bunch of blanks to your current collections sheet
 
Last edited:
Upvote 0
Doh! I left the clear contents on from an old code by accident sorry! I deleted it but still not working.

What I am trying to do, and failing spectacularly, is for it check the tabs listed in I2:I23, on each tab for:

1) In Ranges C5:H79, C86:H160 for any cell that is not blank
2) copy the nonblank cell
3) paste in a tab called Collection in the same column but no blanks in the row.

So
Any data from Column C is copied from the tab and put in the collection tab under Column C but in the next available nonblank row.

Hope that makes more sense than my coding!
 
Upvote 0
Do cells Rows 80 - 85 have data within them?
 
Upvote 0
They do have data, as it is the page split so headings explaining the data on that page when printed but not the data I needed.
 
Upvote 0
Ok, well try this, it works, but it takes a bit of time to run. I am still learning VBA, I know there is a better wat to do this, I just am not sure what that way is..

Code: 
Sub EndofDayBanking()

Dim strName As String
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set C1 = Sheets("Collection").Range("B3")
    Set C2 = Sheets("Collection").Range("C3")
    Set C3 = Sheets("Collection").Range("D3")
    Set C4 = Sheets("Collection").Range("E3")
    Set C5 = Sheets("Collection").Range("F3")
    Set C6 = Sheets("Collection").Range("G3")
        
    For i = 2 To 23
    
    strName = Range("I" & i)
    On Error Resume Next
    
        For Each C In Worksheets(strName).Range("C5:C79").Cells
    
            If Len(C.Value) > 0 Then
                C.Copy
                C1.PasteSpecial Paste:=xlPasteValues
                Set C1 = C1.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
         
        For Each C In Worksheets(strName).Range("C86:C160").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C1.PasteSpecial Paste:=xlPasteValues
                Set C1 = C1.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("D5:D79").Cells
        
                If Len(C.Value) > 0 Then
                C.Copy
                C2.PasteSpecial Paste:=xlPasteValues
                Set C2 = C2.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("D86:D160").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C2.PasteSpecial Paste:=xlPasteValues
                Set C2 = C2.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("E5:E79").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C3.PasteSpecial Paste:=xlPasteValues
                Set C3 = C3.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("E86:E160").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C3.PasteSpecial Paste:=xlPasteValues
                Set C3 = C3.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("F5:F79").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C4.PasteSpecial Paste:=xlPasteValues
                Set C4 = C4.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("F86:F160").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C4.PasteSpecial Paste:=xlPasteValues
                Set C4 = C4.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("G5:G79").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C5.PasteSpecial Paste:=xlPasteValues
                Set C5 = C5.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("G86:G160").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C5.PasteSpecial Paste:=xlPasteValues
                Set C5 = C5.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("H5:H79").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C6.PasteSpecial Paste:=xlPasteValues
                Set C6 = C6.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
        For Each C In Worksheets(strName).Range("H86:H160").Cells
        
            If Len(C.Value) > 0 Then
                C.Copy
                C6.PasteSpecial Paste:=xlPasteValues
                Set C6 = C6.Offset(1, 0) '//advance to next cell below
            End If
            
        Next
            
    Next
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With


End Sub
 
Upvote 0
Thanks - Just ran it, it copies data but it copies it over a hundred times and in all columns :/

Getting there! =)
 
Upvote 0
Not 100% sure what you're looking for then, the code above looks at each sheet, first it looks in column C and pulls every cell that has data in it and pastes it in Column B within the Collection Sheet, then it goes to Column D and pulls every cell with data in it and pastes it in Column C of collections and so on for each column up to column H in each sheet. Each sheets data is then added to the bottom of the previous sheet.

If that is not what you wish then what is? I created a workbook with 23 Sheets, within cells C5 - C79 I added SheetName 1 (so for Sheet2 it read Sheet2 1, Sheet2 2.. ect) then deleted random data rows. The code above worked perfectly for me, on brought in data and only from Column B - G.

Do you have any additional code anywhere else that may be causing additional issues?
 
Last edited:
Upvote 0
it works but it duplicates the last one;

I created a blank spreadsheet with no other code to test it too.

code.png
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
749
Joe4
Joe4
R
  • Question
Loop through Range and Force Formula Calculation
Replies
0
Views
177
reberryjr
R
S
  • Solved
Copy hyperlinks from one table column to another. The columns are identical
Replies
2
Views
73
sspatriots
S
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
231
ItalianPlatinum
I
Z
  • Question
Questions on VBA
Replies
5
Views
152
DanteAmor
DanteAmor

Forum statistics

Threads
1,215,237
Messages
6,123,800
Members
449,127
Latest member
Cyko

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