VBA Range Selection Non Contiguous Cells Using Active Cell

[aspence]

Hi All,

I am trying to copy and paste some data from one sheet to another based on the active cell currently selected. I am using a macro that copies the data from one page to another based on whether there is a value in each row from B21 to B70. This is what I have, and I am getting an error during the range selection process highlighted in red.

Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, rng As Range
Set sh1 = Sheets("APARTMENT UNITS")
Set sh2 = Sheets("INVOICE")
Lastrow = Sheets("INVOICE").Cells(Rows.Count, "B").End(xlUp).Row + 1
For Each c In sh1.Range("B21:B70")
If c.Value <> "" Then
Range(ActiveCell, ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 3), ActiveCell.Offset(0, 38)).Select
Selection.Copy
Sheets("INVOICE").Select
Range ("B" & Lastrow)
Lastrow = Lastrow + 1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next


This way try number 6 changing up that range selection process. I cant seem to get it quite right. I was trying offset cells in this attempt, but have made several attempts with no success.

Basically, there is an active cell selected somewhere in column B. Based on that cell, I need to select and copy the data in the corresponding row columns B, D, E and BN. Then that data is pasted into a different sheet in the next blank row of column B.

Hopefully someone can help me figure out how to select a range of cells that are not contiguous using VBA.

 

[vcoolio]

Hello Aspence,

How about using a double click event code? No button will then be needed.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

        Dim sh2 As Worksheet: Set sh2 = Sheets("INVOICE")
        Dim x As Long: x = Target.Row

Application.ScreenUpdating = False

If Intersect(Target, Range("B21:B70")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub

                    Union(Range("B" & x), Range("D" & x), Range("E" & x), Range("BN" & x)).Copy
                    sh2.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlValues

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

This code needs to be placed in the sh1 sheet module as follows:-

- Right click on the sh1 tab.
- Select "View Code" from the menu that appears.
- In the big white code field that then appears, paste the above code.

Now, each time that you double click on a cell within the range B21:B70 (in effect, your activecell) the data from columns B, D:E, and BN in the row of the activecell will be transferred to sh2.

I hope that this helps.

Cheerio,
vcoolio.

 

[aspence]

That is very neat. I may be able to use this on another project I am working on.

Unfortunately with this application, the range B21:B70 was just a small set of the rows I was testing, and they may or may not have data in them. Potentially, there are thousands of rows that could be used, broken into smaller sets like B21:B70, B82:B196, as examples. Sometimes 5 total rows are used, sometimes 1000. Double clicking each row filled will be very time consuming if there are a significant number of filled rows.

I may not be going about this in the correct way. I figured a run button macro was the best way to go, but it may not work as I intended.

 

[vcoolio]

Hello Aspence,

Oh well. At least you can use it elsewhere!

However, based on your post #3, you could probably make better use of a range Input Box as follows:-

Sub Test()
        
        Dim sh1 As Worksheet: Set sh1 = Sheets("APARTMENT UNITS")
        Dim sh2 As Worksheet: Set sh2 = Sheets("INVOICE")
        Dim rng As Range, c As Range, x As Long
        
        On Error Resume Next
        Set rng = Application.InputBox(Prompt:="Please select a range.", Title:="Select Range", Type:=8)
    
Application.ScreenUpdating = False

        For Each c In rng
                x = c.Row
                If c.Value <> "" Then
                      Union(Range("B" & x), Range("D" & x), Range("E" & x), Range("BN" & x)).Copy
                      sh2.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlValues
                End If
        Next c
        
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Assign the code to a button.
When you click on the button, an Input Box will appear asking you to select a range. Drag your mouse over the required range in Column B and the range address will appear in the Input Box. You could also just type the range into the Input Box.
If you want to enter separate ranges from Column B then drag the mouse over a required range, hold down Ctrl then drag the mouse over the next required range and so on.....
Click OK and the relevant rows of data will be transferred over to sh2.

I hope that this helps.

Cheerio,
vcoolio.