Excel VBA save range reference - excel

I have a range of cells which I'm scanning if the cell has a formular or not.
When it does, I want to save the column letters and row numbers i.e. E14, E18, F18, N18 (Reference) do a dictionary.
Once I've looped through my specific range, I want to select the cells saved in the dictionary to later on delete all cells with formulas in the selected cells.
I am stuck with the part to safe the cell reference to the dictionary.
The range in the example is just an example range.
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
End Sub

You can us a collection for this purpose. You are mentioning a dictionary but for your purpose a key is not that important, you only need a list of items (collection supports both)
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
dim reflist as Collection
Set reflist = new Collection
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
refList.Add rng.Cells(i)
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
Dim oneCell as Range
foreach oneCell in refList
oneCell.Value = vbEmpty
next
End Sub
As you can see we first add the complete cell to the collectdion (it is a referenced object) and later you can use it in the foreach loop to your liking with all its properties

So I was working on resolving the issue to run the VBA faster than looping 2-3x through each column.
My current issue, which I struggle to resolve is: that the defined range "nof" or "DBRW" keeps to increase, which when resolving my final code (delete or copy formula to the Union ranges), the whole Union ranges are selected and therefore formulars are overwritten for the full range, instead of looping from column to column and using the defined formula in that column, which is available in a fixed row (Cells(6, n)).
Option Explicit
Sub Test3()
Dim i As Integer
Dim n As Integer
Dim x As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 32) As Range
Dim nof As Range
Dim nofRange(1 To 32) As Range
Dim rangef As Range
For n = 5 To 6
For i = 13 To 20
If Cells(i, n).HasFormula = True And Cells(7, n) = "A" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(7, n) = "F" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(6, n)
rangef.Copy nof
'Ranges in nof and DBRW are kept (incremented), is there a way to "refresh" the Union reference, to restart creating the range from after this step?
Next n
End Sub
ยดยดยด

so I have solved my issue and for future googlers, this might be helpful :)
Public Sub copy_paste_delete()
Dim i As Integer
Dim n As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 150) As Range
Dim nof As Range
Dim nofRange(1 To 150) As Range
Dim rangef As Range
Application.ScreenUpdating = False
Worksheets("Tab1").Activate
Range("K29").Select
Set DBRW = Nothing
Set nof = Nothing
For n = 61 To 75
Set nof = Nothing
Set DBRW = Nothing
For i = 33 To 38
If Cells(i, n).HasFormula = True And Cells(6, n) = "F" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(6, n) = "A" And Cells(7, n) = "Done" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(19, n)
On Error Resume Next
rangef.Copy nof
Next n
DBRW.Select
'Do some stuff
Application.ScreenUpdating = True
End Sub

Related

Loop through and copy paste values without repetition if conditions are met

Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.

How can I place a formula in the first empty cell on Column F?

How can I place a formula in the first empty cell on Column F?
F3 is empty cell.
Need for that empty cell be =F2
Note: I'm looking for code to look for first empty cell F and I need to be able to insert in the first empty cell =F3.
Currently working with following code copied from here
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell and select it
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Select
Exit For 'This is missing...
End If
Next
Your existing code implies you want to consider truely Empty cells and cells that contain an empty string (or a formula that returns an empty string) Note 1. (Given you simply copied that code from elsewhere, that may not be the case)
You can use End(xlDown) to locate the first truely Empty cell, or Match to locate the first "Empty" cell in a range (either just empty string, or either empty strings or Empty cells, in different forms)
If you want to find the first truely Empty cell, or cell containing an empty string:
Function FindFirstEmptyOrBlankCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty or blank cell
Set FindFirstEmptyOrBlankCell = rng.Cells(StartingAt.Worksheet.Evaluate("Match(True, " & rng.Address & "=""""" & ", 0)"), 1)
End Function
If you want to find the first truely Empty cell, and ignore cells containing an empty string:
Function FindFirstEmptyCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty cell
If IsEmpty(StartingAt.Cells(1, 1)) Then
Set FindFirstEmptyCell = rng.Cells(1, 1)
ElseIf IsEmpty(StartingAt.Cells(2, 1)) Then
Set FindFirstEmptyCell = rng.Cells(2, 1)
Else
Set FindFirstEmptyCell = rng.End(xlDown).Cells(2, 1)
End If
End Function
And for completeness, if you want to find the fisrt cell containing an empty string, and ignore truely Empty cells:
Function FindFirstBlankCell(StartingAt As Range) As Range
Dim rng As Range
Dim idx As Variant
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first blank cell
idx = Application.Match(vbNullString, rng, 0)
If IsError(idx) Then
'There are no Blank cells in the range. Add to end instead
Set FindFirstBlankCell = rng.Cells(rng.Rows.Count, 1)
Else
Set FindFirstBlankCell = rng.Cells(idx, 1)
End If
End Function
In all cases, call like this
Sub Demo()
Dim ws As Worksheet
Dim r As Range
Set ws = ActiveSheet '<~~~ or specify required sheet
Set r = FindFirstEmptyOrBlankCell(ws.Range("F3"))
' literally what was asked for
'r.Formula = "=F3"
' possibly what was actually wanted
r.Formula = "=" & r.Offset(-1, 0).Address(0, 0)
End Sub
Note 1
If IsEmpty(currentRowValue) Or currentRowValue = "" Then is actually redundant. Any value that returns TRUE for IsEmpty(currentRowValue) will also return TRUE of currentRowValue = "" (The reverse does not apply)
From comment can that same Fuction repeat until the last empty cel? I think this is what you mean is to continue to fill blank cells down through the used range
If so, try this
Sub Demo()
Dim ws As Worksheet
Dim cl As Range
Dim r As Range
Set ws = ActiveSheet '<~~~ or specify required sheet
Set cl = ws.Range("F3")
Do
Set r = FindFirstEmptyOrBlankCell(cl)
If r Is Nothing Then Exit Do
r.Formula = "=" & r.Offset(-1, 0).Address(0, 0)
Set cl = r.Offset(1, 0)
Loop
End Sub
Note, I've modified FindFirstEmptyOrBlankCell above to aloow it to return Nothing when it needs to:
Function FindFirstEmptyOrBlankCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty or blank cell
On Error Resume Next ' Allow function to return Nothing
Set FindFirstEmptyOrBlankCell = rng.Cells(StartingAt.Worksheet.Evaluate("Match(True, " & rng.Address & "=""""" & ", 0)"), 1)
End Function
You'll need to change your rowCount, the way you have it, the loop will stop before the first blank row. I believe you should just be able to set use .Formula for the empty cell. Hope this helps:
Sub EmptyCellFillFormula()
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row + 1
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Formula = "=F3"
End If
Next
End Sub

Conditionally hiding columns

I am trying to hide columns (Z,AA,AB,AC) if one of dependent cells are blank. i.e. if Range1 is blank entire column Z is hidden, Range2 is blank then entire column AA is hidden etc.
I know I could implement simple If Else/ .EntireColumn.Hidden statment but I was thinking to use code like below to make it neater. Any suggestions how to make it work ?
Sub(test)
Dim cell As Variant
Dim i As Integer
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("ReturnedHoldMail")
Set MyArray(1) = Sheets("test1").Range("Range1")
Set MyArray(2) = Sheets("test1").Range("Range2")
Set MyArray(3) = Sheets("test1").Range("Range3")
Set MyArray(4) = Sheets("test1").Range("range4")
For i = LBound(MyArray) To UBound(MyArray)
On Error Resume Next
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
Next
Next
End With
End Sub
If you want the ranges that are hidden to be independent of the ranges being tested for emptiness, try the following:
Sub test()
Dim cell As Range
Dim i As Integer
Dim MyArray(1 To 4) As Range
Dim HideArray(1 To 4) As Range
Dim will_hide As Boolean
Set MyArray(1) = Sheets("test1").Range("Range1")
Set MyArray(2) = Sheets("test1").Range("Range2")
Set MyArray(3) = Sheets("test1").Range("Range3")
Set MyArray(4) = Sheets("test1").Range("Range4")
Set HideArray(1) = Sheets("test1").Range("Range5") ' or eg. Sheets("test2").Range("Z:Z")
Set HideArray(2) = Sheets("test1").Range("Range6")
Set HideArray(3) = Sheets("test1").Range("Range7")
Set HideArray(4) = Sheets("test1").Range("Range8")
For i = LBound(MyArray) To UBound(MyArray)
will_hide = True
For Each cell In MyArray(i)
If Len(cell.Value) > 0 Then
will_hide = False
End If
Next
HideArray(i).EntireColumn.Hidden = will_hide
Next
End Sub

Evaluate a list of values in a column against a combobox value most efficiently

I am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?
I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub
Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub

Setting a range based on values (why doesn't this code work?) with VBA/excel

http://i.stack.imgur.com/eBcT5.jpg
I want to create two different ranges, one for everything on the left (column A) of the Ss in column B, and one for everything on the left of the Fs in column B. (see picture)
lastRowA = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
Sub Test2()
Dim rngs As Range
Dim rngf As Range
Dim onleft As Range
i = 1
Do Until i = lastRowA
Cells(i, 2).Activate
Select Case ActiveCell
Case Is = "s"
Set onleft = Cells(i, 1)
Set rngs = Application.Union(rngs, onleft) '<error message for this line
Case Is = "f"
Set onleft = Cells(i, 1)
Set rngf = Application.Union(rngf, onleft)
Case Else
Range("D1").Value = ":("
End Select
i = i + 1
Loop
rngs.Font.Color = RGB(123, 0, 123)
rngf.Font.Color = RGB(255, 0, 0)
End Sub
I would appreciate any adjustments to the code used, or any different ways of going about this problem...
The error I get is :"Invalid procedure call or arguement", Run time error 5.
I didn't use the autofilter because my motive is to use the range to count the numbers. I want to change the colours as a test to see if the code works.
The issue is that, initially, rngs and rngf are Nothing, meaning it is empty and does not refer to a range. When you try to Union the range onleft with Nothing (rngs or rngf) you get the error. The following code solves that problem:
Sub Test2()
Dim rngs As Range
Dim rngf As Range
Dim onleft As Range
lastRowA = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
i = 1
Do Until i = lastRowA
Cells(i, 2).Activate
Select Case ActiveCell
Case Is = "s"
Set onleft = Cells(i, 1)
If rngs Is Nothing Then
Set rngs = onleft 'The first time through, rngs is nothing, so set it equal to onleft
Else
Set rngs = Application.Union(rngs, onleft) 'subsequent times, the onleft is unioned with rngs
End If
Case Is = "f"
Set onleft = Cells(i, 1)
If rngf Is Nothing Then
Set rngf = onleft 'same thing here...
Else
Set rngf = Application.Union(rngf, onleft) '...and here
End If
Case Else
Range("D1").Value = ":("
End Select
i = i + 1
Loop
rngs.Font.Color = RGB(123, 0, 123)
rngf.Font.Color = RGB(255, 0, 0)
End Sub

Resources