For some reason my code isn't working, I've used this type of code a thousand times and for whatever reason it's not matching.. When the column is blank however it does seem to match? Any suggestions on how I can change this or even improve this as I do realise 140,000 records is quite a lot!
Dim name1(140000) As String, name2(140000) As String, answer(140000) As String
For i = 1 To 140000
name1(i) = ActiveWorkbook.Worksheets("Sheet0").Cells(i, 1).value
name2(i) = ActiveWorkbook.Worksheets("Sheet1").Cells(i, 6).value
answer(i) = ActiveWorkbook.Worksheets("Sheet0").Cells(i, 13).value
If name1(i) = name2(i) Then
answer(i) = "yes"
End If
Next
Hi thanks for this, the problem being though the values are changing, so the name in sheet 1 might be in in "A1" but then in sheet 2 be in "F12" and then next week could be in "F14" so its just a way of using the code to update accordingly, also used your vba and still no luck :( – Calum 9 mins ago
A formula is the right way to go. You can use COUNTIF to check for the existence. Put this formula in cell M1 and pull it down.
=IF(COUNTIF($F$1:$F$14000,A1)>0,"Yes","No")
However if you still want to use code, try this (Untested)
Sub Sample()
Dim name1 As Variant, name2 As Variant, answer(1 To 14000) As String
Dim ws As Worksheet
Dim i As Long
With ThisWorkbook
name1 = .Worksheets("Sheet0").Range("A1:A14000").Value
name2 = .Worksheets("Sheet1").Range("F1:F14000").Value
For i = 1 To 14000
If IsInArray(name1(i, 1), name2) Then answer(i) = "Yes" Else answer(i) = "No"
Next i
.Worksheets("Sheet1").Range("M1").Resize(UBound(answer), 1).Value = _
Application.WorksheetFunction.Transpose(answer)
End With
End Sub
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
You are first assigning a value to answer(i) from the Worksheet and then assigning the Yes value if it matches.
However this value gets assigned to answer() not to the Cell.
you need to change:
answer(i) = "yes"
to
ActiveWorkbook.Worksheets("Sheet0").Cells(i, 13).Value = "yes"
and remove answer() completely.
The better way would be this:
=IF(A1=F1;"Yes";"No")
Related
I was trying to delete my unwanted columns in the ACTIVE sheet using the below code :
Sub DeleteUnwantedColumns()
Dim LastUsedCell As Integer
Dim deleteRange As Range
LastUsedCell = ActiveSheet.UsedRange.Columns.count
Set deleteRange = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, LastUsedCell))
arr = Array("FY17", "FY18", "FY19", "FY20", "FY21")
For Each cell In ActiveWorkbook.Worksheets("Sheet1").Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, LastUsedCell))
If IsError(Application.Match(cell.Value, arr, 0)) Then
ActiveSheet.Cells.EntireColumn.Delete
End If
Next
End Sub
with this code sheets are deleting which is not mentioned in the Array, but if i am deleting the column 2 then column 3 will be the column 2, so in that case the code is skipping the column 2 if the value is something else in the column 2.
is there any way to work this code from last usedcolumn to first column.
i tried with step-1 , but it showing an error in the code itself.
any help is appreciated.
Thank you in Advance
Use a for loop and go backwards from usedRange.Columns.Count with Step -1. You never used DeleteRange so I removed it.
Sub DeleteUnwantedColumns()
Dim arr As Variant
Dim c As Integer
arr = Array("FY17", "FY18", "FY19", "FY20", "FY21")
For c = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
If IsError(Application.Match(ActiveSheet.Cells(1, c), arr, 0)) Then
ActiveSheet.Columns(c).Delete
End If
Next
End Sub
I am trying to write a VBA code to autofill range A1:A10000 with numbers 1 to 10000 but without entering 1 in A1 and 2 in A2 to create a range.
Basically, I need a code that looks like this:
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
(1,2).AutoFill Destination:=fillRange
Of course this does not work, but you get what it.
Writing and reading to/from the worksheet are some of the slowest actions you can perform. Writing time-efficient code means doing as much in memory as you can.
Try writing all your values into an array, then writing the whole thing to the worksheet in one shot, something like this:
Sub printRange(total As Integer)
Dim i, myRange() As Integer
ReDim myRange(1 To total)
For i = 1 To total:
myRange(i) = i
Next i
'Use Transpose to shift the 1d array into a column
Worksheets("Sheet1").Range("A1:A" & UBound(myRange)).Value = _
Application.WorksheetFunction.Transpose(myRange)
End Sub
For total = 10000, this pretty much runs instantly, even on a ten year old dinosaur desktop.
Dim fillRange As Range
Dim i As Long
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
With fillRange
For i = .Cells(1, 1).Row To .Cells(.Rows.Count, 1).Row
.Cells(i, 1).Value = i
Next i
End With 'fillRange
Or with AutoFill :
With Worksheets("Sheet1")
Range("A1").Value = 1
Range("A2").Value = 2
Range("A1:A2").AutoFill Destination:=Range("A1:A10000")
End With 'Worksheets("Sheet1")
this should be fast enough
you could use the following function
Function FillNumbers(rng As Range) As Variant
Dim i As Long
ReDim nmbrs(1 To rng.Rows.Count)
For i = 1 To UBound(nmbrs)
nmbrs(i) = i
Next
FillNumbers = Application.Transpose(nmbrs)
End Function
in the following manner
With Worksheets("Sheet1").Range("A1:A10000")
.Value = FillNumbers(.Cells)
End With
Can't you use a simple loop?
For i = 1 to 10000
Worksheets("Sheet1").Cells(i, 1) = i
Next i
Dim fillRagne As Range
Set fillRange = Range(Cells(1, 1), Cells(1000, 1))
For Each cell in fillRange
cell.value = cell.Row
Next cell
I'm trying to create a VBA function that starts from the bottom of a range, and returns the first value that's different from the value at the bottom.
Example:
In the above table, I'd like to be able to grab the last value in the "Month" column (11), and iterate to the top until the value 10 is reached, and return that value.
I just started looking into VBA 3 days ago and am very unfamiliar with the language so I'm still trying to grok the syntax.
I have no doubt that my thinking is fuzzy with this, so I'd really appreciate feedback on my errors.
Here's what I have right now:
Code:
Function NextValue(num1 As Range)
For c = num1.End(xlDown) To num1.Item(1)
If Cells(c, 1) <> num1.End(xlDown) Then
NextValue = Cells(c, 1)
Exit For
End If
Next c
End Function
In case it's not clear, here's a description of what I'm trying to do, line-by-line.
1). Initiate a For-Loop that begins at the end of a range and decrements to the top
2). Check if that cell does not match the last value in that column
3). If it does not, then set the value of the function to that value
4). Terminate If statements, For loops, and end the function.
Your help is greatly appreciated.
Try this:
Function NextValue(num1 As Range) as Integer
Dim y As Integer
'get the last cell from num1
Set num1 = num1.End(xlDown)
y = -1
Do Until num1.Offset(y, 0).Value <> num1.Value
y = y - 1
Loop
'set function return to the different cell
NextValue = num1.Offset(y, 0).value
End Function
This will handle both compact ranges and disjoint ranges:
Option Explicit
Public Function SomethingElse(rng As Range) As Variant
Dim r As Range, values() As Variant
Dim i As Long, strvalue As Variant
ReDim values(1 To rng.Count)
i = 1
For Each r In rng
values(i) = r.Value
i = i + 1
Next r
strvalue = values(rng.Count)
For i = rng.Count To 1 Step -1
If values(i) <> strvalue Then
SomethingElse = values(i)
Exit Function
End If
Next i
SomethingElse = CVErr(xlErrNA)
End Function
Not clear to me if you want an UDF or a code to be used in a macro
in the first case you've already been given answers
in the latter case you may want to consider these two options:
Public Function FirstDifferent(rng As Range) As Variant
With rng.Parent.UsedRange
With Intersect(.Resize(, 1).Offset(, .Columns.Count), rng.EntireRow)
.Value = rng.Value
.RemoveDuplicates Array(1)
FirstDifferent = .Cells(.Rows.Count, 1).End(xlUp).Offset(-1).Value
If FirstDifferent = .Cells(.Rows.Count, 1) Then FirstDifferent = "#N/A"
.ClearContents
End With
End With
End Function
Public Function FirstDifferent(rng As Range) As Variant
With rng.Resize(, 1)
.AutoFilter Field:=1, Criteria1:=.Cells(.Rows.Count, 1)
FirstDifferent = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Cells(1, 1).Offset(-1).Value ' = 0 '<-- if any rows filtered other than headers one then change their column "B" value to zero
If FirstDifferent = .Cells(.Rows.Count, 1) Then FirstDifferent = "#N/A"
.Parent.AutoFilterMode = False
End With
End Function
I am working with an excel workbook where I want to find all unique values in a column.
I have code that works by looping through all the rows and for each row looping through a collection of values seen so far and checking if I've seen it before.
It works like this.
Function getUnique(Optional col As Integer) As Collection
If col = 0 Then col = 2
Dim values As Collection
Dim value As Variant
Dim i As Integer
Dim toAdd As Boolean
i = 3 'first row with data
Set values = New Collection
Do While Cells(i, col) <> ""
toAdd = True
For Each value In values
If Cells(i, col).value = value Then toAdd = False
Next value
If toAdd Then values.Add (Cells(i, col).value)
i = i + 1
Loop
Set getUnique = values
End Function
However, Excel AutoFilter is able to find these values much faster. Is there a way to filter and then read the unique values?
I've tried using the AutoFilter.Filters object but all of the .ItemX.Criteria1 values have a "Application-defined or object-defined error" (found using a watch on ActiveSheet.AutoFilter.Filters).
This isn't quite doing what you describe, I think it's processing it less-efficiently because it's checking every cell against every value.
I think this is probably inefficient, because as the values collection grows in length, the second loop will take longer to process.
You could get some improvement if you exit your nested For early:
Do While Cells(i, col) <> ""
For Each value In values
If Cells(i, col).value = value Then
toAdd = False
Else:
values.Add (Cells(i, col).value)
Exit For '### If the value is found, there's no use in checking the rest of the values!
End If
Next value
i = i + 1
Loop
But I think a Dictionary may give you performance improvement. This way, we don't need to loop over the collection, we just make use of the dictionary's .Exists method. If it doesn't exist, we add to the collection, if it does, we don't. Then the function still returns the collection of uniques.
Function getUnique(Optional col As Integer) As Collection
If col = 0 Then col = 2
Dim values As Object
Dim value As Variant
Dim i As Integer
Dim toAdd As Boolean
Dim ret as New Collection
i = 3 'first row with data
Set values = CreateObject("Scripting.Dictionary")
With Cells(i, col)
Do While .Value <> ""
If Not values.Exists(.Value)
values(.Value) = 1
ret.Add(.Value) '## Add the item to your collection
Else
'## Count the occurences, in case you need to use this later
values(.Value) = values(.Value) + 1
End If
i = i + 1
Loop
Set getUnique = ret
End Function
The AdvancedFilter method may come in handy here and produce cleaner, easier to maintain code. This will work so long as you are calling this Function from another VBA module and not from a cell.
Function getUnique(Optional col As Integer) As Collection
If col = 0 Then col = 2
Dim values As Collection
Dim value As Variant
Dim i As Integer
i = 3 'first row with data
Range(Cells(i, col), Cells(Rows.Count, col).End(xlUp)).AdvancedFilter xlFilterCopy, CopyToRange:=Cells(1, Columns.Count)
Set values = New Collection
Dim cel As Range
For Each cel In Range(Cells(1, Columns.Count), Cells(1, Columns.Count).End(xlDown))
values.Add cel.value
Next
Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Clear
Set getUnique = values
End Function
Tested with this sub:
Sub Test()
Dim c As Collection
Set c = getUnique(4)
For i = 1 To c.Count
Debug.Print c.Item(i)
Next
End Sub
I'm trying to use the trim function without success. After searching for the solution on this forum and other sources online I have seen many different approaches.
Is there no simple way of trimming a cell in VBA?
What I want is something like this:
Sub trimloop()
Dim row As Integer
row = 1
Do While Cells(row, 1) <> ""
Cells(row, 2) = trim(Cells(row, 2))
row = row + 1
Loop
So that when there is a value in column A (1) the value in column B (2) should be trimmed of any extra spaces. I just cant get this to work for me.
Appreciate any help/tips!
Regards
Jim
So i made the code a bit accurate and mistakeproof and it worked.
So i can recommend you to double check, if you have correct row and column values, because you probably targeting wrong cells. (cause your code is working)
Sub trimloop()
Dim row As Integer
Dim currentSheet As Worksheet
Set currentSheet = sheets("Sheet1")
row = 2
Do While currentSheet.Cells(row, 1) <> ""
currentSheet.Cells(row, 2).Value = Trim(currentSheet.Cells(row, 2).Value)
row = row + 1
Loop
End Sub
Use Application.WorksheetFunction.Trim(string)
Sub trimloop()
Dim row As Integer
row = 1
With ThisWorkbook.ActiveSheet
Do While .Cells(row, 1) <> ""
.Cells(row, 2) = Application.WorksheetFunction.Trim(.Cells(row, 2))
row = row + 1
Loop
End With
End Sub
this is the optimized version of your code, in case of big data sheets:
Option Explicit
Sub trimloop()
Dim row As Long, max As Long
Dim Data() As Variant
With ThisWorkbook.Sheets(1)
max = .Cells(1, 1).End(xlDown).row 'this does the same as your code, on first empty cell it stops
'the following finds the last un-empty cell of column(1):
'max= .cells(.rows.count,1).end(xlup).row
'copies values from sheet to memory (is faster for working with later)
Data = .Range(.Cells(1, 1), .Cells(max, 2)).Value2
'loop :
For row = 2 To max + 1
'work with memory instead of sheet
Data(row, 2) = Trim(Data(row, 2))
'for complete delete of all spaces use : = replace( StringName," ", "")
Next row
'write back to sheet
.Range(.Cells(1, 1), .Cells(max, 2)).Value2 = Data
End With
erase Data 'free memory
End Sub
Don't know if this overly simplified... but thought I would simply throw it out there this worked for me. The only predecessor step is you assign a "named range" to your workbook/worksheet/dataset ... name a data set and then iterate over the data set with this code
Sub forEachLoop()
For Each cell In Range("yourNamedRange")
cell.Value = Trim(cell.Value)
Next cell
End Sub