I'm new to Excel VBA and have double and triple checked my code and still can't seem to find the issue.
I'm trying to iterate through a column (A) and create a unique identifier of the concatenation of value in column C and a random number between 1 and 6MIL. I am also iterating through column C.
Appreciate any help in advance!
Here is my code:
Sub unique_id()
Dim c As Range
For Each i In Range("A:A")
For Each x In Range("C:C")
If IsNull(i.Value) = True Then
i.Value = Concat(x.Value, RandBetween(1, 6000000))
End If
End If
Next x
Next i
End Sub
There are a few things that need addressing in your code:
You are doing a nested loop over all cells in 2 columns (that's over 1,000,000,000,000,000,000 calculations per loop), as you can figure, not the best idea, rather set the range at the beginning
Dim all of your variables correctly, as pointed out in the comments
I'm assuming by using the IsNull() function you are implying that there's no value in the cell? In that case it's better to use if val = "" then
You need to take into account error checking, part of this being that if you are creating unique IDs you need to check whether they really are unique (already exist or not)
Try the following code out, adjust as necessary
Sub unique_ID()
Dim c As Range
Dim rng As Range
Dim uniqueID As String
Dim dupeFlag As Boolean 'flag to check for duplicate IDs
Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("C")) 'goes through only the cells which have been used
For Each c In rng.Cells
If CStr(c.Offset(, -2).value) = "" Then 'checks if col A has any value inside
dupeFlag = True 'turns flag on for the while loop
Do While dupeFlag
uniqueID = c.value & Application.WorksheetFunction.RandBetween(1, 6000000) 'create the unique ID
If findDuplicate(uniqueID, rng.Offset(, -2)) = False Then 'checks if the ID already exists
c.Offset(, -2) = uniqueID 'if ID doesn't exist then then write it to col A
dupeFlag = False 'flag turns off to go to next cell
End If
Loop
End If
Next
End Sub
Function findDuplicate(val As String, srchRng As Range) As Boolean
'function to check if a duplicate is found in a range (the above macro calls it)
Dim cell As Range
For Each cell In srchRng.Cells
If cell.value = val Then
findDuplicate = True
Exit Function
End If
Next
findDuplicate = False
End Function
Related
Is it possible to find a row with 2 criteria?
I'm importing survey anwsers to a worksheet, now I want to find the answers of a specified person
I need to find the row in the worksheet(ImportLimesurvey) that has 2 specified cell values:
In that row:
the value of the C-cell has to be one of the highest value in that column (I used the function Application.WorksheetFunction.Max(rng))
This value means how much of the survey is filled in. The highest value stands in multiple answer-rows. The highest value is different for every survey. (example, if a survey has 7 pages and the participant fills in all pages :the highest value is 7 for that person, but if the person didn't complete that survey, the value could be e.g. 3), So the filter of the highest value is if the participant completed the whole survey.
the value of the L-cell has to be the same as the cell (Worksheets("Dataimport").Range("M2")
M2= accountnumber of the person I need the answers from
The correct row has to be pasted to (Worksheets("Dataimport").Range("A7")
This is my current code:
Dim g As Range
Dim rng As Range
Set rng = Worksheets("ImportLimesurvey").Range("C:C")
d = Application.WorksheetFunction.Max(rng)
With Worksheets("ImportLimesurvey").Range("L:L")
Set g = .Find(Worksheets("Dataimport").Range("M2"), LookIn:=xlValues)
g.Activate
End With
e = Range("C" & (ActiveCell.Row))
If e = d Then
ActiveCell.EntireRow.Copy _
Destination:=Worksheets("Dataimport").Range("A7")
End If
The problem here is that he finds the row with the right account number, but the answer with the C-value isn't always the highest. It picks (logically) just the first row with that accountnumber. So how can I find the row that matches those 2 criteria?
Thanks in advance
P.S. I'm new to VBA so I tried to be as specific as possible but if you need any additional info, just ask for it ;)
dmt32 forom mrexcel.com found a solution.
Link to topic: https://www.mrexcel.com/board/threads/find-row-with-2-criteria.1157983/
His code works fine:
Sub FindMaxValue()
Dim FoundCell As Range, rng As Range
Dim MaxValue As Long
Dim Search As String, FirstAddress As String
Dim wsDataImport As Worksheet, wsImportLimesurvey As Worksheet
With ThisWorkbook
Set wsDataImport = .Worksheets("Dataimport")
Set wsImportLimesurvey = .Worksheets("ImportLimesurvey")
End With
Search = wsDataImport.Range("M2").Value
If Len(Search) = 0 Then Exit Sub
With wsImportLimesurvey
Set FoundCell = .Range("L:L").Find(Search, LookIn:=xlValues, lookat:=xlWhole)
If Not FoundCell Is Nothing Then
FirstAddress = FoundCell.Address
Do
With FoundCell.Offset(, -9)
If .Value > MaxValue Then Set rng = FoundCell: MaxValue = .Value
End With
Set FoundCell = .Range("L:L").FindNext(FoundCell)
If FoundCell Is Nothing Then Exit Do
Loop Until FoundCell.Address = FirstAddress
rng.EntireRow.Copy wsDataImport.Range("A7")
MsgBox Search & Chr(10) & "Record Copied", 64, "Match Found"
Else
MsgBox Search & Chr(10) & "Record Not Found", 48, "Not Found"
End If
End With
End Sub
Still thanks for the tips.
Firstly, Visual Basic conceptual topics is a great read to help in writing 'better' code. The biggest thing I encourage is to use meaningful variable names.
It's much easier to understand your code when you have variable names like HighestCount or TargetSheet etc. rather than names like a or b etc.
The answer to your question is yes.
I would write something like this:
Option Explicit
Public Function HighestSurveyRow(ByVal TargetAccountNumber As Long) As Long
Dim ImportLimeSurveySheet As Worksheet
Set ImportLimeSurveySheet = ThisWorkbook.Sheets("ImportLimeSurvey")
Dim LastRow As Long
Dim TargetRow As Long
Dim SurveyCountArray As Variant
Dim ArrayCounter As Long
With ImportLimeSurveySheet
ArrayCounter = 1
LastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
ReDim SurveyCountArray(1 To LastRow, 1 To 2)
For TargetRow = 1 To LastRow
If .Cells(TargetRow, 12).Value = TargetAccountNumber Then
SurveyCountArray(ArrayCounter, 2) = TargetRow
SurveyCountArray(ArrayCounter, 1) = .Cells(TargetRow, 3).Value
ArrayCounter = ArrayCounter + 1
End If
Next TargetRow
End With
Dim ResultArray(1 To 2) As Variant
Dim ArrayElement As Long
For ArrayElement = 1 To UBound(SurveyCountArray, 1)
If SurveyCountArray(ArrayElement, 1) > ResultArray(1) Then
ResultArray(1) = SurveyCountArray(ArrayElement, 1)
ResultArray(2) = SurveyCountArray(ArrayElement, 2)
End If
Next ArrayElement
HighestSurveyRow = ResultArray(1)
End Function
Sub FindRowForSurveyResults()
With ThisWorkbook.Sheets("DataImport")
.Range("A7").Value = HighestSurveyRow(.Range("M2").Value)
End With
End Sub
It's split into a Function and a Subroutine. The Function executes most of the code and returns the row number. The Sub calls this function and writes this returned value to cell A7 on "DataImport".
The sub can be broken down as follows;
Using a with statement helps reduce code clutter of defining the worksheet twice.
The only thing the sub is doing is assigning a value to cell A7. To get the value it calls the function and assigns the parameter TargetAccountNumber as the value from cell M2.
The function can be broken down into the following steps;
All variables are declared and the target worksheet for the function is set.
The LastRow of column L is found to establish our maximum length of the Array and search range.
The Loop searches from Row 1 to the LastRow and compares the values from column L. If it matches the TargetAccountNumber parameter then the column C value and the row number are stored into the Array.
Once the Loop is done, another Loop is run to find the highest number. The first iteration will always store the first row's data. Each iteration after that compares the values stored in the SurveyCountArray with the current value of ResultArray(1) and if the value is greater, ResultArray(1) is updated with the value, ResultArray(2) is updated with the Row number.
Once the 2nd loop is done, the Row in ResultArray(2) is assigned to the function for the Sub to write to the worksheet.
It can definately be improved and refined to work faster and more efficiently, especially if you have a very large data set, but this should help get you thinking about ways you can use loops and arrays to find data.
Note: There could be duplicate rows for the outcome (say a user submits the same survey 3 times with the same answers), which I haven't tested for - I think this code would return the highest row number that matches the required criteria but could be tweaked to throw an error or message or even write all row numbers to the sheet.
I'd like a macro to clear all cells in a given range on a worksheet UNLESS it has (specifically) LIST validation. (In that case I want to make it = 'Select'.)
So... I need the macro to:
1)check all cells within a range on the sheet
2)if the cell does NOT have (specifically) LIST validation it will make the cell = ""
3)if the cell DOES have (specifically) LIST validation it will make the cell = 'Select'
Something like this:
Dim x as variant
with thisworkbook.sheets("audits")
For each x in .range("A6:AZ200")
if x.validationtype = "list" then
x.value = "Select"
else
x.value = ""
end if
next x
end with
Thanks!
You can probably use the SpecialCells property of a range object to return ONLY the cells with validation, and then do another check to ensure that the validation type is List.
Dim rng As Range
Dim vRng As Range
Dim cl As Range
Set rng = thisworkbook.sheets("audits").Range("A6:AZ200") 'Modify as needed
'Get a range of ONLY the validation cells
Set vRng = rng.SpecialCells(xlCellTypeAllValidation)
For Each cl In rng
'If the cell has NO VALIDATION:
If Intersect(cl, vRng) Is Nothing Then
cl.ClearContents
ElseIf cl.Validation.Type = 3 Then 'xlValidateList
cl.Value = "Select"
End If
Next
Note: 3 is the xlDVType constant for "List" validation. You could alternatively use the constant expression: xlValidateList
The above should handle mixed validation type, and will do nothing with any other sort of validation. If it's safe to assume that ONLY list validation is used, then try condensing it as:
Set vRng = rng.SpecialCells(xlCellTypeAllValidation)
vRng.Value = "Select"
For Each cl In rng
'If the cell has NO VALIDATION:
If Intersect(cl, vRng) Is Nothing Then
cl.ClearContents
End If
Next
This would be one way to do it. In order to keep the error handling away from your main routine I've put the validation checker into a standalone function:
Sub clear_validation()
Dim x As Range
With ThisWorkbook.Sheets("audits")
For Each x In .Range("A6:AZ200")
If validationtype(x) = 3 Then
x.Value = "Select"
Else
x.Value = ""
End If
Next x
End With
End Sub
Function validationtype(cl As Range)
Dim t As Integer
t = 0
On Error Resume Next
t = cl.Validation.Type
On Error GoTo 0
validationtype = t
End Function
It's flicker-y, so you might want to temporarily turn off screen updating, and perhaps calculations while it's running, but I think this does what you're after.
Proper syntax Match and If not isblank
I need some assistance with creating a loop statement that will determine the range start and end where a particular criteria is met.
I found these statements on the web and need help to modify them to loop thru two different worksheets to update a value on 1 of the worksheets.
This one has an issue returning True or False value for the Range when I want to pass the actual named range for look up where this field = Y, then returns the value from another column. I original tried using Match and If is not blank function. But that is very limiting.
See the previous post to see what I am trying to accomplish - I know I will need to expand the code samples and probably will need help with this modification.
Sub Test3()
Dim x As Integer
Dim nName As String
Sheets("BalanceSheet").Select
nName = Range("qryDifference[[Validate Adjustment]]").Select
Debug.PrintnName
' Set numrows = number of rows of data.
NumRows = Range(nName, Range(nName).End(xlDown)).Rows.Count
' Select cell a1.
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
' Insert your code here.
MsgBox"Value found in cell " & ActiveCell.Address
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
This is what I have so far - this is giving me and issue with
ActiveCell.Offset(4, 0).Select
nAgentNo = Range("qryDifference[[agtno]]").Value
nValidate = Range("ryDifference[[Difference]]").Value
Debug.Print nAgentNo
Debug.Print nValidate
Type mismatch error on the above.
Sub Revised_AgentAmount()
Dim myRange As Range
Dim i As Long, j As Long
Dim nAgentNo As String
Dim nValidate As Long
Sheets("BalanceSheet").Select
Set myRange = Range("qryDifference[[Validate Adjustment]]")
For i = 1 To myRange.Rows.Count
For j = 1 To myRange.Columns.Count
If myRange(i, j).Value = "Y" Then
ActiveCell.Offset(4, 0).Select
nAgentNo = Range("qryDifference[[agtno]]").Value
nValidate = Range("ryDifference[[Difference]]").Value
Debug.Print nAgentNo
Debug.Print nValidate
End If
Next j
Next i
End Sub
In your first statement you declare nName as a String then try to select it. You would need to declare it as a Range if you are going to use it as a Range object.
I found solution elsewhere with a if statement instead of the for loop.
=IF([#agtno]=B24,[#[agt_amt]],SUMPRODUCT((Balance!$B$2:$B$7=[#agtno])*(Balance!$F$2:$F$7="Y")*Balance!$E$2:$E$7)+[#[agt_amt]])
I have a list of values in column A, and another list of values in column B.
I am trying to have a single cell in column C indicate TRUE if any value in column A is in Column B, or FALSE is no value in column A is in Column B.
I tried MATCH(lookup value, in range), but that only looks at one value in A.
Is it possible to do this without VBA? Open to VBA solutions also. Thanks
Here is a quick and dirty UDF that will do it.
Public Function Exist(a As Range, b As Range) As Boolean
Dim temp As Boolean
temp = False
For Each cel In a
If WorksheetFunction.CountIf(b, cel.value) > 0 Then
temp = True
Exit For
End If
Next cel
exist = temp
End Function
I've used something like this to compare values in one list to another in VBA. Could take a while if you have a lot of values to check. Just set the B range to however large the range is on your sheet.
Option Explicit
Dim Index As Long
Dim valueFound As Range
Sub compareAandB()
Index = 2
Do While ThisWorkbook.ActiveSheet.Cells(Index, 1) <> ""
Set valueFound = ThisWorkbook.ActiveSheet.Range("B2:B1000").Find(ThisWorkbook.ActiveSheet.Cells(Index, 1))
If valueFound Is Nothing Then
ThisWorkbook.ActiveSheet.Cells(Index, 3) = "Not Found"
Else
ThisWorkbook.ActiveSheet.Cells(Index, 3) = "Found"
End If
Index = Index + 1
Loop
End Sub
I have a database app that stores data in array formulas through a UDF.
I would like to have a macro that goes through the sheet/wbook and breaks all the external links by replacing the udf array formula with the current value in the given cell.
The challenge is that cells within a given array formula can't be written individually. For example a macro like that below will cause the entire array to be destroyed on the first write.
Public Sub breaklink()
Dim c
For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
Debug.Print c.FormulaArray
If InStr(c.FormulaArray, "MYFORMULA(") Then
Stop
c.FormulaArray = c.Value
'c.Value = c.Value --THIS THROWS ERROR 1004 (Can't edit part of an array)
Stop
End If
Next
End Sub
If there were a cell method like c.getArrayFormulaRange, then I could use it to create an array of values and then write-over the array formula.
I could conceivably loop through adjacent cells to attempt to find the bounds of each array, but this seems quite cumbersome (also, I'd be changing the range I was looping through during the loop, which could raise problems). Is there any method or object property that will help me identify the entire range that is occupied by a given array formula?
Following simpLE MAn's suggestions above, this is my solution:
Public Sub breakLinks(scope As String)
Dim formula_tokens()
Dim c As Range, fa_range As Range
Dim ws As Worksheet
Dim token
formula_tokens = Array("MYFORMULA1(", "MYFORMULA2(", "OTHERFORMULA(", "OTHERFORMULA2(")
If scope = "sheet" Then
For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
For Each token In formula_tokens
If InStr(UCase(c.FormulaArray), token) Then
If c.HasArray Then
Set fa_range = c.CurrentArray
fa_range.FormulaArray = fa_range.Value
Else
c.Formula = c.Value
End If
End If
Next
Next
ElseIf scope = "wbook" Then
For Each ws In Worksheets
For Each c In ws.Cells.SpecialCells(xlCellTypeFormulas)
For Each token In formula_tokens
If InStr(UCase(c.FormulaArray), token) Then
If c.HasArray Then
Set fa_range = c.CurrentArray
fa_range.FormulaArray = fa_range.Value
Else
c.Formula = c.Value
End If
End If
Next
Next
Next
End If
End Sub