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

danno79

New Member
Joined
Oct 28, 2009
Messages
45
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...

Code:
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 ;)....
 

Some videos you may like

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

pgc01

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,884
Hi

Try:

Code:
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

New Member
Joined
Oct 28, 2009
Messages
45
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

New Member
Joined
Oct 28, 2009
Messages
45
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

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,884

ADVERTISEMENT

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:

Code:
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

New Member
Joined
Oct 28, 2009
Messages
45
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 :)

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

pgc01

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,884
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,295
Messages
5,600,785
Members
414,405
Latest member
Zaurb

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
Top