Results 1 to 4 of 4
  1. #1
    Join Date
    Dec 2007
    Posts
    70

    Unanswered: Copying and pasting discontinuous cells

    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

  2. #2
    Join Date
    Sep 2008
    Location
    London, UK
    Posts
    511
    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.
    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...
    Last edited by Colin Legg; 03-10-10 at 07:14.

  3. #3
    Join Date
    Dec 2007
    Posts
    70
    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

  4. #4
    Join Date
    Sep 2008
    Location
    London, UK
    Posts
    511
    Hi Owain,
    GetLastRow() Function and I copied it from someone called Colin_L on a different thread
    I thought I recognised it from somewhere....

    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •