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!
 
Sort by date Sort by votes
Is there any additional data in Column I or just the sheet names? Also do you NEED the sheet names or are they just there for the code to work for you? If you can answer these questions I may be able to get you a faster code.

Here is the code, it works now, was a clipboard issue

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 = [COLOR=#333333]Range("I" & i)[/COLOR]
    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
            Application.CutCopyMode = False
        Next
            
    Next
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub
 
Last edited:
Upvote 0
Thanks for all your help! That works amazingly!

Column I just has the tab names in but they change often which I have another VBA code to update.
 
Upvote 0
Try this one, does not matter if you have 2 or 2000 sheets (and no need to keep track of the sheet names in column I any longer with this) this will review each of them and run the macro on them. I have also reduced a lot of un-required code. There is no need to copy and paste, just make one cell = the others value.

This will run A LOT faster for you, let me know what you think...

Code: 
Sub EndofDayBanking()

Dim ws As Worksheet

    With Sheets("Collection")
        Set C1 = .Range("B3")
        Set C2 = .Range("C3")
        Set C3 = .Range("D3")
        Set C4 = .Range("E3")
        Set C5 = .Range("F3")
        Set C6 = .Range("G3")
    End With
    
    For Each ws In ThisWorkbook.Worksheets
    
        If Not ws.Name = "Collection" Then
    
            On Error Resume Next
        
            For Each c In ws.Range("C5:C79", "C86:C160").Cells
                If Len(c.Value) > 0 Then
                    C1.Value = c.Value
                    Set C1 = C1.Offset(1, 0) '//advance to next cell below
                End If
            Next
                       
            For Each c In ws.Range("D5:D79", "D86:D160").Cells
                If Len(c.Value) > 0 Then
                    C2.Value = c.Value
                    Set C2 = C2.Offset(1, 0) '//advance to next cell below
                End If
            Next
                
            For Each c In ws.Range("E5:E79", "E86:E160").Cells
                If Len(c.Value) > 0 Then
                    C3.Value = c.Value
                    Set C3 = C3.Offset(1, 0) '//advance to next cell below
                End If
            Next
                
            For Each c In ws.Range("F5:F79", "F86:F160").Cells
                If Len(c.Value) > 0 Then
                    C4.Value = c.Value
                    Set C4 = C4.Offset(1, 0) '//advance to next cell below
                End If
            Next
                
            For Each c In ws.Range("G5:G79", "G86:G160").Cells
                If Len(c.Value) > 0 Then
                    C5.Value = c.Value
                    Set C5 = C5.Offset(1, 0) '//advance to next cell below
                End If
            Next
                
            For Each c In ws.Range("H5:H79", "H86:H160").Cells
                If Len(c.Value) > 0 Then
                    c.Value
                    Set C6 = C6.Offset(1, 0) '//advance to next cell below
                End If

            Next

        End If

    Next


End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

yearego021
  • Solved
VBA to Save as PDF broken with unwanted deleting of tabs.
Replies
7
Views
293
Artik
Artik
B
  • Solved
VBA - Copying Non-Contiguous Ranges in/out of (an) Array(s)
2
Replies
18
Views
565
kvsrinivasamurthy
K
K
  • Question Question
Two different worksheets with similar VBA's to send out emails getting Ambiguous name detected: RangetoHTML
Replies
1
Views
87
kac1125
K
S
  • Question Question
Named Ranges Just Stopped Working Correctly
Replies
3
Views
256
SewStage
S
V
  • Question Question
Copy data from 1 sheet and paste in another sheet.
Replies
2
Views
73
Vasanth88ece
V

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