For loop to capture values in different named ranges - excel

I have been looking through multiple posts on looping through multiple named ranges and returning values to another cell. Unfortunately, I am getting stuck on how to loop through two named ranges to return the value from one named range if a cell in another named range is "X".
Below are images of the named ranges with values and the intended result in cell I46. Please note there is no formula in I46.
Named Ranges: Range1 Range2
Desired result from macro aftter loop is complete:
Code:
For Each Cell In wspGen.Range("Ineligible")
If Cell.Value = vbNullString Then
LP.zPledge.Value = "Y"
wspGen.Range("A46") = "-"
wspGen.Range("AG55").Value = "X"
Else
If Cell.Value = "X" Then
wspGen.Range("AG55").Value = vbNullString
wspGen.Range("A45").Value = "N"
LP.zPledge.Value = "N"
'Copies the corresponding value from range ("IneligibilityCode")
'if there is an "X" in any of the cells in range ("Ineligible")
'to I46. This could be multiple combinations of values in range ("IneligibilityCode")
End If
End If
Next Cell
Thank you all for your assistance.

This is a simple example using a counter variable assuming both ranges are single column and aligned. It counts how many cells down the first named range
(set in variable a) it is before x is found and retrieves the value at the same position in the named range b. Note I am using implicit active sheet references and you should specify the sheet name before the named ranges.
Option Explicit
Public Sub test()
Dim a As Range, b As Range, rng As Range, counter As Long
Set a = Range("range1"): Set b = Range("range2")
For Each rng In a
counter = counter + 1
If rng = "x" Then
Range("I46") = b.Cells(counter)
Exit For
End If
Next
End Sub
Space separated list of all matches:
Option Explicit
Public Sub test()
Dim a As Range, b As Range, rng As Range, counter As Long, outputString As String
Set a = Range("range1"): Set b = Range("range2")
For Each rng In a
counter = counter + 1
If rng = "x" Then
outputString = outputString & Chr$(32) & b.Cells(counter)
End If
Next
wspGen.Range("I46") = Trim$(outputString) ' wspGen.Range("I46") is defined in your code. This is illustrative.
End Sub

Related

For each loop in VBA Excel

I am a beginner in VBA trying to loop through cells from a specified range that is entered into a refEdit on a user form, this range always has 2 columns but could have any number of rows. The first column is a category and the second column is numerical values. I want to find the sum of the corresponding values of a specific category. For example, very time I come across the word "coffee" in a cell I want to take the value in the cell to its right and start summing them to print the value of all coffee in cell C1. How can I get this to work?
Here is what I have been working with:
dim cell, myRange as Range
dim c as string
dim r as long
Set myRange = Range(RefEdit1.Text)
c = "coffee"
r = 0
For Each cell In myRange
If VBA.LCase(cell) = VBA.LCase(c) Then
r = r + ActiveCell.Offset(0, 1).Value
End If
next cell
range("C1") = r
SumIf vs Loop
Loops are usually best avoided due to slowing down the code.
SumIf 'is' not case-sensitive so you are also avoiding the 'LCase-business'.
When declaring variables in one line, you have to 'use an As' for each variable or it will be declared as Variant (cell).
Option Explicit
Sub testSumIf()
Dim myRange As Range
Dim c As String
Set myRange = Range(RefEdit1.Text)
c = "coffee"
Range("C1").Value _
= Application.SumIf(myRange.Columns(1), c, myRange.Columns(2))
End Sub
Sub testLoop()
Dim cell As Range, myRange As Range
Dim c As String
Dim r As Long
Set myRange = Range(RefEdit1.Text)
c = VBA.LCase("coffee")
For Each cell In myRange.Cells
If VBA.LCase(cell.Value) = c Then
r = r + cell.Offset(0, 1).Value
End If
Next cell
Range("C1").Value = r
End Sub

How to get the column letter of the first non blank cell of a range in VBA?

I need to get the column letter of the first non-blank cell of a range. This range is basically a part of a row like.
Example:
Range = A2:G2
First non blank cell is on F2 cell.
Need to get 'F' and store it in a String variable.
What is the most efficient way to get this?
Thanks
Try this:
Sub columnName()
Dim mainRange As Range, cell As Range, columnName As String
Set mainRange = Range("A2:G2")
'Set mainRange = Selection
For Each cell In mainRange.Cells
If Not IsEmpty(cell.Value) Then
MsgBox Split(cell.Address, "$")(1)
Exit For
End If
Next cell
End Sub
You can get that column letter with a function:
Function firstBlankCol(rg As Range) As String
Dim x
If rg(1) = "" Then
x = rg(1).Address
Else
x = rg(1).End(xlToRight).Offset(0, 1).Address
End If
firstBlankCol = Split(x, "$")(1)
End Function
However, it is simpler, usually, to deal with the column number, and use that for the column argument of the Cells property.
Function firstBlankCol(rg As Range) As Long
Dim x
If rg(1) = "" Then
x = rg(1).Column
Else
x = rg(1).End(xlToRight).Column + 1
End If
firstBlankCol = x
End Function

Copy values from cells in range and paste them in random cell in range

I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range.
I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it.
Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub
Maybe something like this ?
Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")
For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i
For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub
I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5.
The second for i = 1 to 5 is to offset from column B to G.
The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.
This if I'm not wrong to get what you mean.
Here's another approach, just for a bit of variety.
Sub x()
Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long
Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range
With WorksheetFunction
Do Until .Count(r2) = r2.Count 'loop until output range filled
r = .RandBetween(1, 25) 'random output cell number
If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
If r2.Cells(r) = vbNullString Then 'if random cell empty
r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
i = i + 1
End If
End If
Loop
End With
End Sub

loop through each row in a given range with if statement with multiple conditions in vba

I'm trying to loop trough each row in the range J16:P19, and with every iteration, it must be checked if the value in the cell = 3, and if the text in the corresponding coloumn (range J15:J19) is present in the range ( W1:W7).
eg. If the cell (K17) in the row (J17:P17) = 3 & the corresponding coloumn name (K15) of that cell is present in the range ( W1:W7); the value of in Q17 must be substracked by 1.
This should be done for every row in the range. My code looks like this:
private Sub CommandButton2_Click()
dim rng As Range
dim i As Range
dim row As Range
Set rng = Range("j16:p19")
For Each row In rng.Rows
For Each i In row.Cells
If i.Value = 3 & Cells(i,15) %in% Range("w1:w7") Then
Cells(row,22).Value = Cells(row,17).Value -1
Else
Cells(row,22).Value = Cells(row,17).Value
End if
Next i
Next row
End sub
It works when I select the range to be one column only, and without the second part of the if statement. Do you have any suggestions on have to solve my problem? thank you in advance
Try this.
Not sure why you were referring to column 22? Also "%in%" is not valid VBA syntax. I've used Match instead (which avoids the outer loop), but you could use Find or Countif.
Private Sub CommandButton2_Click()
Dim rng As Range
Dim i As Range
Dim row1 As Range, v As Variant 'better in my view not to call a variable "row"
Set rng = Range("j16:p19")
For Each row1 In rng.Rows
v = Application.Match(3, row1, 0)
If IsNumeric(v) Then 'row contains a 3
If IsNumeric(Application.Match(Cells(row1.row,"J"), Range("W1:W7"), 0)) Then 'corresponding J column value in W1:W7
Cells(row1.row, "Q").Value = Cells(row1.row, "Q").Value - 1 'deduct 1 from Q
End If
End If
Next row1
End Sub

How to set and use empty range in VBA?

I would like to use empty range in following manner :
Set NewRange = Union(EmptyRange, SomeRange)
I've tried to set EmptyRange as empty range using Nothing, Empty and Null but "run-time error '5' Invalid procedure call or argument" occurs, it seems that I have to use If statement or there is other keyword which do the job ?
I can use :
If EmptyRange Is Nothing Then
Set NewRange = SomeRange
Else
Set NewRange = Union(EmptyRange, SomeRange)
End If
instead of construction:
Set NewRange = Union(EmptyRange, SomeRange)
I use this function as a replacement for Application.Union when I need to combine several range objects, where "zero or more" of the ranges might be Nothing:
Function union(ParamArray rgs() As Variant) As Range
Dim i As Long
For i = 0 To UBound(rgs())
If Not rgs(i) Is Nothing Then
If union Is Nothing Then Set union = rgs(i) Else Set union = Application.union(union, rgs(i))
End If
Next i
End Function
Example Usage:
Sub demo_union()
Dim rg1 As Range, rg2 As Range, rg3 As Range, newRg As Range
Set rg1 = Range("A1")
Set rg3 = Range("C3")
Set newRg = union(rg1, rg2, rg3)
newRg.Select
End Sub
Below is a variation that does not duplicate overlapping cells in the returned range.
Normally when combining overlapping ranges (eg., A1:B2 and B2:C3) with Application.Union (or the function above), the result will have multiple copies of the overlapping cells.
For example using,
Application.Union([A1:B2], [B2:C3]).Cells.Count '8 cells (repeats B2)
↑ ...returns 8 cells: A1 B1 A2 B2 B2 C2 B3 C3
(and a For Each loop will have 8 iterations.)
Function union2 (below) solves this issue by returning only unique cells, and also handles empty ranges (without producing an annoyingly-vague "Invalid Procedure call or argument")
Debug.Print union2([A1:B2], [B2:C3]).Cells.Count '7 cells
↑ ...returns 7 cells: A1 B1 A2 B2 C2 B3 C3
(For Each loop will have 7 iterations.)
I used an extra variable to fix this problem. I did not use If EmptyRange Is Nothing but if my counter, j, = 0 then NewRange = SomeRange. Here is my code:
Public Sub copyLineData(line_array As Variant)
' Copys data from the line into the right sheet
Dim i As Integer
Dim j As Integer
Dim line As String
Dim rgn_data As Range
Dim rgn_selected As Range
Dim table_data As ListObject
Set rgn_data = getDynamicRangeFromSheet(Worksheets("Data"), "A1")
Set table_data = Sheets("Data").ListObjects.Add(xlSrcRange, rgn_data, xlListObjectHasHeaders:=xlYes)
' Get the selected rows
For i = 0 To ArrayLen(line_array) - 1
line = line_array(i)
' Make selection
table_data.Range.AutoFilter Field:=1, Criteria1:=line
' Copy data
j = 0
For Each Row In table_data.DataBodyRange.Rows
If Row.EntireRow.Hidden = False Then
If j = 0 Then
Set rgn_selected = Row
Else
Set rgn_selected = Union(Row, rgn_selected)
End If
j = j + 1
End If
Next Row
' Copy selection
rgn_selected.Copy Destination:=Sheets(line).Range("A1")
Next i
' Remove selection
table_data.Range.AutoFilter
' Convert back to range
table_data.Unlist
End Sub
You still can use Application.Union using Null as EmptyRange.
Dim ActualRange As Range: Set ActualRange = ThisWorkbook.Sheets(1).Cells(1,1)
EmptyRange = Null
Result = Union(ActualRange, ActualRange, EmptyRange)
The trick is to supply ActualRange twice (as Union wants two mandatory parameters and don't mind if they are the same) and use third optional parameter to do the magic.
Then if you need to start from nothing you can do this:
MyRange = Null
For each Cell In SomeRange.Cells
If ThisIsMyCell(Cell) Then MyRange = Union(Cell, Cell, MyRange)
Next
The Union() method requires at least 2 named ranges. It combines the two named ranges into one master range. If your true goal is to combine SomeRange with an Empty range, then you should just write:
Set NewRange = SomeRange
Your use of the Union() method is pointless because Union() requires two DEFINED ranges.
http://msdn.microsoft.com/en-us/library/office/aa213609%28v=office.11%29.aspx

Resources