Copying and pasting discontinuous cells

OB1 · #1 (**permalink**) 03-09-10, 20:19

Hi, I hope someone can help me. I've done a bit of work with VB in Access but am new to VB Excel. I'm trying to copy cells from one column to the same column on a different worksheet but the cells copied will have blank cells in and I want the pasted cells on the other sheet to put the values (which are dates) one after the other with no blank cell in between. Then I'd like it to move onto the next column in my table. I've managed to piece together this code but it doesn't seem to work at all. What am I doing wrong, remember I'm a beginner so please be gentle with me!!!

Code:

Sub Chironomid_Failure()


    On Error GoTo ErrorChiron

    
    Dim sheet As Worksheet
    Dim Fail As Worksheet
    Dim myrange As Range
    Dim i As Integer
    Dim cl As Integer
    Dim iFail As Integer
    Dim LastRow As Long
    
    
    Set sheet = Sheet1
    Set Fail = Sheet2

    Application.ScreenUpdating = False

    For cl = 2 To 10
        For i = 5 To 56
        
            Worksheets(sheet).Select
            Worksheets(sheet).Cells(i, cl).Select

                    If ActiveCell = "" Then

                    Else
                        ActiveCell.Value.Copy
                        
                        Worksheets(Fail).Select
                        Worksheets(Fail).Cells(iFail, cl).Select
                            
                        'get the last used row in Sheet(fail)!cl:cl
                        LastRow = GetLastRow(Fail.Range("cl:cl"))
    
                        'put a value in the next row down
                        Worksheets(Fail).Cells(LastRow + 1, "cl").PasteSpecial xlPasteAllExceptBorders

                                
                    End If

        Next i
            
    Next cl

    Application.ScreenUpdating = True

                            

ErrorChiron:

        Exit Sub


End Sub

Code:

Public Function GetLastRow(ByVal rngToCheck As Range) As Long

    Dim rngLast As Range
    
    Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious)
    
    If rngLast Is Nothing Then
        GetLastRow = rngToCheck.Row
    Else
        GetLastRow = rngLast.Row
    End If
    
End Function

Colin Legg · #2 (**permalink**) 03-10-10, 05:27

Hi,

You've made a pretty good effort there - I particularly like your GetLastRow() function.

One thing I noticed is that you're not quite calling it correctly:

Code:

LastRow = GetLastRow(Fail.Range("cl:cl"))

The range C1:C1 only has one row, so GetLastRow will always return 1 here.

The Excel object model can be hard to navigate at the best of times but, if you know what you're looking for, it contains a few treasures.

Quote:

I'm trying to copy cells from one column to the same column on a different worksheet but the cells copied will have blank cells in and I want the pasted cells on the other sheet to put the values (which are dates) one after the other with no blank cell in between.

The easiest way to do this is to copy everything over in one go and then to delete all of the empty cells. There's a very convenient Range.SpecialCells() method which (amongst other things) can be used to reference empty cells within a range. Here's an example:

Code:

Sub foo()
    
    Dim rngBlanks As Range
    Dim lngLastRow As Long
    
    'find the last row in Sheet1!B:K
    lngLastRow = GetLastRow(Sheet1.Range("B:K"))
    
    'copy Sheet1!B:K to Sheet2!B:K
    Sheet2.Range("B1:K" & lngLastRow).Value = Sheet1.Range("B1:K" & lngLastRow).Value
    
    'get a reference to any blanks cells within Sheet2!B:K
    'if there aren't any blanks then the range.specialcells method returns an error
    On Error Resume Next
    Set rngBlanks = Sheet2.Range("B1:K" & lngLastRow).SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    
    'if we found any blank cells then delete them
    If Not rngBlanks Is Nothing Then
        rngBlanks.Delete shift:=xlShiftUp
    End If
    
End Sub

Public Function GetLastRow(ByVal rngToCheck As Range) As Long

    Dim rngLast As Range
    
    Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious)
    
    If rngLast Is Nothing Then
        GetLastRow = rngToCheck.Row
    Else
        GetLastRow = rngLast.Row
    End If
    
End Function

There are a couple of things that need to be pointed out.

Range.SpecialCells() has a limit of 8,192 non-contiguous cells so if you have a really huge (in Excel terms), broken data set then we might have to revise the strategy. This limitation has been increased to available memory in XL 2010.

Deleting cells can be slow, particularly in large workbooks. This is because it triggers a full recalculation and because the grid has to be repainted. So whilst this is a convenient approach, it is not necessarily the most efficient. There are a few tricks which can be used to speed it up such as temporarily setting Application.ScreenUpdating to False but, if you find it's just too slow, we can look at a different way such as sorting or filtering.

Hope that helps...

OB1 · #3 (**permalink**) 03-10-10, 17:05

Hi, That great thanx Colin_L, worked fantastically!

Its just what I needed as I'm only working with small data sets.

I must (embarisingly) admit though that the only part of my code that was any good was the GetLastRow() Function and I copied it from someone called Colin_L

on a different thread so I can't take credit for it!!

What a learning curve though!!

Thanks Again,

Owain

Colin Legg · #4 (**permalink**) 03-10-10, 17:13

Hi Owain,

Quote:

GetLastRow() Function and I copied it from someone called Colin_L on a different thread

I thought I recognised it from somewhere....

Quote:

What a learning curve though!!

Yeah, the Excel object model is pretty vast and hard to navigate. If you've got any questions about the code I posted, such as "Why did you do this?", then feel free to ask - I'm always happy to take the time to explain to someone who's keen to learn.

Good luck with your project.

Internet Services

Web Development

Digital Marketing

Consumer Tech