Find non-consecutive blanks in a range and paste contents of another range -

[danno79]

The Code below copies from a range, looks for the right number of consecutive blank cells in the desitnation range and pastes cells. (need to retain cell/number formats)

I would like to achieve somehting similar, but the blank cells don't have to be consecutive, there just need to be enough blank cells in the destination range to accomodate the total in SomeRng, and would need to work from top of range down, as the values of SomeRng are in ascending order. Also need the range SomeRng dynamic/variable in length (but always 1 column wide) Any suggestions greatly appreciated...

Sub testme()

Dim myRng As Range
Dim myDestRng As Range
Dim myCell As Range
Dim HowMany As Long
Dim DestCell As Range
Dim SomeRng As Range

HowMany = Range("b1").Value

With ActiveSheet
Set SomeRng = .Range("a1:a4") 'something to copy

Set myDestRng = .Range("a8:a35")
Set myRng = Nothing
On Error Resume Next
Set myRng = myDestRng.Cells.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
End With

If myRng Is Nothing Then
MsgBox "No empty cells in the Destination range: " _
& myDestRng.Address(0, 0)
Else
Set DestCell = Nothing
For Each myCell In myRng.Cells
If Application.CountA(myCell.Resize(HowMany, 1)) = 0 Then
Set DestCell = myCell
Exit For
End If
Next myCell

If DestCell Is Nothing Then
MsgBox HowMany & " consecutive empty cells not available"
Else
If Intersect(DestCell.Resize(HowMany, 1), myDestRng).Address _
<> DestCell.Resize(HowMany, 1).Address Then
MsgBox "Found a blank cell at: " & DestCell.Address(0, 0) _
& vbLf & "but not enough empty cells under it"
Else
SomeRng.Copy _
Destination:=DestCell
MsgBox "Pasted into: " _
& DestCell.Resize(HowMany, 1).Address(0, 0)
End If
End If
End If
End Sub

By the way this board has beeen a lifeline for a VBA newbie like myself - thanks so much for your help and guidance people ....

 

[pgc01]

Hi

Try:

Sub CopyToBlanks()
Dim rSrc As Range          ' source range
Dim rDest As Range        ' destination range
Dim rBlanks As Range     ' blanks in the destination range
Dim rC As Range             ' loop cell
Dim lRow As Long           ' row to copy in the source range

With ActiveSheet
    Set rSrc = Range("a1:a4")
    Set rDest = Range("a8:a35")
End With
 
On Error Resume Next
Set rBlanks = rDest.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
 
If rBlanks Is Nothing Then
    MsgBox "No empty cells in the Destination range: " & rDest.Address(0, 0)
ElseIf rBlanks.Count < rSrc.Count Then
    MsgBox "Not enough empty cells in the Destination range. " & rDest.Address(0, 0)
Else
    'copy the cells
    For Each rC In rBlanks
        lRow = lRow + 1
        rSrc(lRow).Copy Destination:=rC
    Next rC
End If
End Sub

 

[danno79]

Thanks PCG this is pretty mcuh what i was trying to do - how would you modify this so that it ignores any cells in rSrc that are blank?

 

[danno79]

Hi PGC any pointers on how to limit rSrc to those cells which are't blank? I'm guessing I would need to perform something like a counta on the range to find the number of nonblanks and then pass that into the where the input range is specified but I'm not sure how to do this. Any help gratefully recieved

 

[pgc01]

Hi

If some of the cells in rScr are empty, you must skip them. You can loop through the cells in rSrc and test if they are empty, ex:

Sub CopyToBlanks()
Dim rSrc As Range                ' source range
Dim rDest As Range              ' destination range
Dim lConstSrc As Long           ' number of constants in the source range
Dim rBlanksDest As Range     ' blanks in the destination range
Dim rC As Range                   ' loop cell
Dim lRow As Long                 ' row to copy in the source range
 
With ActiveSheet
    Set rSrc = Range("a1:a4")
    Set rDest = Range("a8:a35")
End With
 
On Error Resume Next
lConstSrc = rSrc.SpecialCells(xlCellTypeConstants).Count
Set rBlanksDest = rDest.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
 
If rBlanksDest Is Nothing Then
    MsgBox "No empty cells in the Destination range: " & rDest.Address(0, 0)
ElseIf rBlanksDest.Count < lConstSrc Then
    MsgBox "Not enough empty cells in the Destination range. " & rDest.Address(0, 0)
Else
    For Each rC In rBlanksDest
        
        ' look for next cell in source range that is not empty
        Do
            lRow = lRow + 1
        Loop While IsEmpty(rSrc(lRow)) And (lRow <= rSrc.Count)
        If lRow > rSrc.Count Then Exit For
        
        rSrc(lRow).Copy Destination:=rC
    Next rC
End If
End Sub

 

[danno79]

thanks pgc - i inserted the code below which assumes that the blanks are always at the bottom of the range and the rest of the column is empty below that, but your solution is much more robust cheers

Set rSrc = Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row)

 

[pgc01]

Hi

I'm glad it helped. If you are sure, however, that the blanks are at the bottom and the source list is the only thing you have in column A, then you should use your code instead, as it will be more efficient.