Using VBA to add active cell address to a range - vba

I'm trying to use this answer to apply my own sort of adding active cell address to a range so I can select the whole range later to a apply a conditional formatting. Below is my code but I'm not sure what is wrong. It came up with the error "Compile Error: Type Mismatch"
p/s: I have recorded my macro on this particular set of cells and then editted it.
Sub Macro1()
Dim rng2 As Range
Range("B3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("D3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("F3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("H3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("J3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("L3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("N3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("P3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("R3").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("R7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("P7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("N7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("L7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("J7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("H7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("F7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("D7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("B7").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("B11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("D11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("F11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range("J11").Select
Set rng2 = Union(rng2, ActiveCell.Address)
Range(rng2).Select
End Sub


Your first Set rng2 = Union(rng2, ActiveCell.Address) should be Set rng2 = ActiveCell. You cannot union to a range object that is nothing and rng2 is nothing until it is set to something so it cannot be part of the union statement.
Each subsequent Set rng2 = Union(rng2, ActiveCell.Address) should be Set rng2 = Union(rng2, ActiveCell). You cannot union to a range object's string address; you must union to a range object.
rng2 is now a valid range object and does not require further definition. Range(rng2).Select is invalid; simply use rng2.Select.
For all intents and purposes, you could have just stated,
Range("B3, D3, F3, H3, J3, L3, N3, P3, R3, R7, P7, N7, L7, J7, H7, F7, D7, B7, B11, D11, F11, J11").Select
You mentioned in a comment that you cut off your code due to space restrictions. Consider the following loop.
dim i as long, rng2 as range
Set rng2 = Range("B3, D3, F3, H3, J3, L3, N3, P3, R3")
For i = 7 To 23 Step 4
Set rng2 = Union(rng2, Intersect(rng2.EntireColumn, Rows(i)))
Next i
rng2.select
rng2.interior.color = vbred
Debug.Print rng2.Address(0, 0)
'B3,D3,F3,H3,J3,L3,N3,P3,R3,B7,D7,F7,H7,J7,L7,N7,P7,R7,B11,D11,F11,H11,J11,L11,N11,P11,R11,B15,D15,F15,H15,J15,L15,N15,P15,R15,B19,D19,F19,H19,J19,L19,N19,P19,R19,B23,D23,F23,H23,J23,L23,N23,P23,R23
The debug.print messages go to the VBE's Immediate window.

Related

If And statement comparing values of same row

I have written the below code to isolate unique values when comparing range 1 and range 2. I want it to also evaluate the cell in the same row in range 3 to make sure it is not equal to zero. Any tips on how to accomplish that?
Sub CompareRanges()
Dim WorkRng1 As Range, WorkRng2 As Range, WorkRng3 As Range, Rng1 As Range, Rng2 As Range, Rng3 As Range
xTitleId = "Compare Ranges"
Set WorkRng1 = Application.InputBox("Please Select Task ID Range in Invoice Review File", xTitleId, Type:=8)
Set WorkRng2 = Application.InputBox("Please Select Task ID Range in Budget Grid", xTitleId, Type:=8)
Set WorkRng3 = Application.InputBox("Please Select", xTitleId, Type:=8)
For Each Rng1 In WorkRng1
For Each Rng2 In WorkRng2
If Rng1.Value = Rng2.Value Then
Rng2.Interior.Color = VBA.RGB(254, 255, 255)
Exit For
End If
Next
Next
For Each Rng2 In WorkRng2
For Each Rng3 In WorkRng3
If Rng2.Value > 0 And Rng3.Value <> 0 And Rng2.Interior.Color <> VBA.RGB(254, 255, 255) Then
Rng2.Interior.Color = VBA.RGB(255, 0, 0)
Exit For
End If
Next
Next
End Sub

As Portland Runner answered:
Try: And Cells(Rng2.Row, Rng3.Column) <> 0 instead of And
Rng3.Value <> 0

Invalid Procedure Call or argument in vbaExcel while Writing into sheet3

Sub Duplicate()
Dim WorkRng1 As Range, WorkRng2 As Range, Rng1 As Range, Rng2 As Range
Set ws = ThisWorkbook.Sheets("Sheet3")
xTitleId = "KutoolsforExcel"
Set WorkRng1 = Application.InputBox("Range A:", xTitleId, "", Type:=8)
Set WorkRng2 = Application.InputBox("Range B:", xTitleId, Type:=8)
For Each Rng1 In WorkRng1
rng1Value = Rng1.Value
For Each Rng2 In WorkRng2
If rng1Value = Rng2.Value Then
MsgBox rng1Value
Rng1.Interior.Color = VBA.RGB(255, 0, 0)
Else
ws.Cells("A2") = rng1Value
Exit For
End If
Next
Next
End Sub

How to select a range in column A that parallel to selected range (the selected range is Non-Contiguous range) without Looping

If the selected range is Rng1 = C1:D2,C4:D5 , the result range must be Rng2 = A1:A2,A4:A5 .
I use two ways that work fine if Rng1 is Contiguous but both not work if Rng1 is Non-Contiguous range:
Sub test()
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = Range("C1:D2,C4:D5")
'first way:
Set Rng2 = Rng1.Resize(, 1).Offset(, 1 - Rng1.Column)
'second way:
Set Rng2 = Range(Cells(Rng1(1).Row, 1), Cells(Rng1(Rng1.Count).Row, 1))
Rng2.Select
End Sub
So can we do that without looping through Rng1 Rows or Areas.

Sub test()
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = Range("C1:D2,C4:D5")
Set Rng1 = Rng1.EntireRow
Set Rng2 = Intersect(Rng1, Rng1.Parent.Columns(1))
End Sub

Add location of cell to SUM formula

Is there any way to add the location of a cell into a SUM formula?
I have the following For Each ... Next loop, but instead of merely counting the number of cells that contain a value of 1, I would like to add the specific location of such a cell into a SUM formula.
Dim rng As Range, cell As Range
Set rng = Range("I3:DC70")
For Each cell In rng
If cell.Value = 1 Then Range("DF4").Value = Range("DF4").Value + 1
Next cell
Is this possible?

You will have to use .Find and .FindNext. You can read about it Here. This approach is much faster than looping when you have a large dataset.
Here is something that I wrote quickly. Please amend it to suit your needs.
Sub Find_Cells_Which_Has_My_Damn_String()
Dim WhatToFind As String
Dim aCell As Range, bCell As Range
Dim SearchRange As Range, rng As Range
Dim ws As Worksheet
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Set here what to find
WhatToFind = "1"
'~~> Set this to the relevant range
Set SearchRange = ws.Cells
Set aCell = SearchRange.Find(What:=WhatToFind, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
Set rng = aCell
Do
Set aCell = SearchRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Set rng = Union(rng, aCell)
Else
Exit Do
End If
Loop
End If
If Not rng Is Nothing Then MsgBox rng.Address Else _
MsgBox "No cells were found containing " & WhatToFind
End Sub
Screenshot

Excel VBA Dynamic Ranges

I'm looking to improve my code to dynamically set ranges where data exist instead of hard coding the values. The starting value of the range will never change, but the ending value will if more month columns are added. What is the best way to approach this. Would be easier to make the range user defined?
Here's what I have:
The code will split data by unique group name starting at C5 into separate worksheets.
Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim Rng As Range
Dim Rng1 As Range
Dim vrb As Boolean
Dim sht As Worksheet
'Find unique value for splitting
Set Rng = Sheets("Sheet1").Range("C5")
'Find starting row to copy (Re-code to dynamically set)
Set Rng1 = Sheets("Sheet1").Range("A5:M5")
vrb = False
Do While Rng <> ""
For Each sht In Worksheets
If sht.Name = Left(Rng.Value, 31) Then
sht.Select
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
ActiveCell.Offset(1, 0).Activate
Set Rng1 = Rng1.Offset(1, 0)
Set Rng = Rng.Offset(1, 0)
vrb = True
End If
Next sht
If vrb = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Left(Rng.Value, 31)
'Copy header rows (Re-code to dynamically set) to new worksheet first cell
Sheets("Sheet1").Range("A4:M4").Copy ActiveSheet.Range("A1")
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
Set Rng1 = Rng1.Offset(1, 0)
Set Rng = Rng.Offset(1, 0)
End If
vrb = False
Loop
End Sub

Here's the updated code for anyone who stumbles across this question.
Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim vrb As Boolean
Dim sht As Worksheet
Dim R_Start, R_End, H_Start, H_End As Range
'Set Header
Set H_Start = Cells(4, 1)
Set H_End = H_Start.End(xlToRight)
'Set Data range
Set R_Start = Cells(5, 1)
Set R_End = R_Start.End(xlToRight)
'Find unique value for splitting
Set rng = Sheets("Sheet1").Range("C5")
'Find starting row to copy
Set Rng1 = Range(R_Start, R_End)
Set Rng2 = Range(H_Start, H_End)
vrb = False
Do While rng <> ""
For Each sht In Worksheets
If sht.Name = Left(rng.Value, 31) Then
sht.Select
Range("A2").Select
Do While Selection <> ""
ActiveCell.Offset(1, 0).Activate
Loop
Rng1.Copy ActiveCell
ActiveCell.Offset(1, 0).Activate
Set Rng1 = Rng1.Offset(1, 0)
Set rng = rng.Offset(1, 0)
vrb = True
End If
Next sht
If vrb = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Left(rng.Value, 31)
'Copy header rows to new worksheet first cell
Rng2.Copy ActiveSheet.Range("A1")
Range("A2").Select
Rng1.Copy ActiveCell
Set Rng1 = Rng1.Offset(1, 0)
Set rng = rng.Offset(1, 0)
End If
vrb = False
Loop
End Sub