In Excel file I have 600000 rows and below code take too much time to execute. It is getting 150 rows in 1 minuter. Any suggestion to improve the below code?
For i = 2 To UBound(vArray, 1)
With Worksheets(1).Range("C2:C" & Z)
Set c = .Find(Sheet2.Cells(i, "A"), LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
If Sheet2.Cells(i, "A") = Sheet.Cells(c.Row, 3) Then
If UCase(Sheet1.Cells(c.Row, "D")) = "AVDELING" Then
Sheet2.Cells(i, 2) = Sheet1.Cells(c.Row, 5)
ElseIf UCase(Sheet1.Cells(c.Row, "D")) = "PROSJEKT" Then
Sheet2.Cells(i, 3) = Sheet1.Cells(c.Row, 5)
End If
End If
Set c = .FindNext(c)
If firstaddress = c.Address Then
GoTo end_this
End If
Loop While Not c Is Nothing
End If
End With
end_this:
Next i
Try using memory arrays rather than Excel ranges for searching and storing your results. The code below executes in a few seconds.
Sub Test()
Dim findWhat() As Variant
Dim findIn() As Variant
Dim rowNum As Long
Dim findIndex As Long
Dim results() As Variant
findWhat = Array("A10", "B5", "C3")
findIn = Range("A1:A640000").Value
results = Range("B1:D640000").Value
For findIndex = LBound(findWhat) To UBound(findWhat)
For rowNum = LBound(findIn) To UBound(findIn)
If findWhat(findIndex) = findIn(rowNum, 1) Then
results(rowNum, 1) = "Found " & findIndex
End If
Next rowNum
Next findIndex
Range("B1:D640000").Value = results
End Sub
Related
I need to pass the variables max, min, and their respective locations to another sub where it will format each max and min in their respective column. I am trying to create an array that will store the locations and the values but its not working.
I was told to first identify the number of columns used and the number of rows, which is the beginning.
Rows = wsData.UsedRange.Rows.Count
Columns = wsData.UsedRange.Col.Count
j = 1
ReDim Min(j)
With wsData.Range("A3:A19")
For j = 1 To 19 'colum
Min(j) = WorksheetFunction.Min(Range(.Offset(1, j), .Offset(Row, j)))
Max = WorksheetFunction.Max(Range(.Offset(1, j), .Offset(Row, j)))
Min(j) = Min
j = j + 1
ReDim Preserve Min(j) 'saves variables
Next 'next column
End With
The code below uses the ActiveSheet which you need to change to reference the worksheet for your data. Additionally, it assumes that your data starts with Row 1. The code looks at each column in the range and stores the minimum/maximum (it does not account for multiple cells which may share the min or max value) value found in the column as well as the cell's address, in an array and then passes the array to two different subs, one which simply displays the information in a message and one which formats the the background color of the cells. This code does not perform any kind of error handling, but should get you where you want to go.
the line Option Explicit requires that all of the variables be defined using a Dim statement
the line Option Base 1 makes the default starting point for arrays 1 instead of 0
Option Explicit
Option Base 1
Sub GatherData()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim iMin() As Variant
Dim iMax() As Variant
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
ReDim iMin(iCols, 2)
ReDim iMax(iCols, 2)
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMin(j, 1) = R.Value
iMin(j, 2) = R.Address
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMax(j, 1) = R.Value
iMax(j, 2) = R.Address
Next j
ListMinMax iMax(), True
ListMinMax iMin(), False
FormatMinMax iMax, "green"
FormatMinMax iMin, "yellow"
Set R = Nothing
End Sub
Sub ListMinMax(ByRef Arr() As Variant, ByVal MinMax As Boolean)
Dim strOutput As String
Dim i As Long
If MinMax = True Then
strOutput = "Maximums:" & vbCrLf & vbCrLf
Else
strOutput = "Minimums:" & vbCrLf & vbCrLf
End If
For i = 1 To UBound(Arr, 1)
strOutput = strOutput & "Cell: " & Arr(i, 2) & " = " & Arr(i, 1) & vbCrLf
Next i
MsgBox strOutput, vbOKOnly
End Sub
Sub FormatMinMax(ByRef Arr() As Variant, ByVal BGColor As String)
Dim i As Long
Select Case UCase(BGColor)
Case "GREEN"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbGreen
Next i
Case "YELLOW"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbYellow
Next i
Case Else
MsgBox "Invalid Option", vbCritical
End Select
End Sub
======================================================================
The code below does away with the need for the arrays and formats the color of the min/max values as it finds them
Sub GatherData2()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbYellow
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbGreen
Next j
Set R = Nothing
End Sub
I read many post on this forum regarding my problem, but cant find solutions.
I have a table with different number of cells, with duplicate value.
I would like to count duplicates and show in another columns.
Source table where I mark a few cell:
I would like to receive such output
A have a part of code, but whatever I select, it counts the last cell
Dim rng, rngTarget, rngTargetName As Range
Set rngTarget = Range("D7")
Set items = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If Not items.exists(rng.Value) Then
items.Add rng.Value, 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
Else
items(rng.Value) = items(rng.Value) + 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
End If
Next
What i missing?
First enter this in a Standard Module:
Public Function unikue(rng As Range)
Dim arr, c As Collection, r As Range
Dim nCall As Long, nColl As Long
Dim i As Long
Set c = New Collection
nCall = Application.Caller.Count
On Error Resume Next
For Each r In rng
If r.Value <> "" Then
c.Add r.Text, CStr(r.Text)
End If
Next r
On Error GoTo 0
nColl = c.Count
If nCall > nColl Then
ReDim arr(1 To nCall, 1 To 1)
For i = 1 To nCall
arr(i, 1) = ""
Next i
Else
ReDim arr(1 To nColl, 1 To 1)
End If
For i = 1 To nColl
arr(i, 1) = c.Item(i)
Next i
unikue = arr
End Function
The above UDF() will return a list of the unique, non-blank, items in a block of cells.
Then in a set of cells in column, say F starting at F5 , array-enter:
=unikue(A1:D3)
In G5 enter:
=COUNTIF($A$1:$D$3,F5)
and copy downward:
With Excel 365, there is a no-VBA solution.
Thanks Gary's for help, but ...
i completed my version of code and now works as expected - i can select few cell and count duplicates.
My working code:
Dim rng As Range
Dim var As Variant
Dim i As Integer
i = 0
Set D = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If rng <> "" Then
If D.exists(rng.Value) Then
D(rng.Value) = D(rng.Value) + 1
Else
D.Add rng.Value, 1
End If
End If
Next
For Each var In D.Keys
Range("C" & (i + 18)) = var
Range("E" & (i + 18)) = D(var)
i = i + 1
Next
Set D = Nothing
I have Excel Database which i just want to input only the tag number and i will automatic display the result in textbox... but in takes 30sec to display the result
Private Sub cmdSearch_Click()
Dim x As Long
Dim y As Long
x = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row
For y = 1 To x
If Sheets("Clients").Cells(y, 1).Text = TextBox1.Value Then
TextBox1.Text = Sheets("Clients").Cells(y, 1)
TextBox4.Text = Sheets("Clients").Cells(y, 3)
TextBox5.Text = Sheets("Clients").Cells(y, 4)
TextBox10.Text = Sheets("Clients").Cells(y, 5)
TextBox11.Text = Sheets("Clients").Cells(y, 6)
TextBox12.Text = Sheets("Clients").Cells(y, 7)
TextBox13.Text = Sheets("Clients").Cells(y, 8)
End If
Next y
End Sub
Match is pretty fast
Private Sub cmdSearch_Click()
Dim m As VARIANT
With Sheets("Clients")
m = Application.Match(TextBox1.Value, .Columns(1), 0)
If not iserror(m) then
TextBox4.Text = .Cells(m, 3)
TextBox4.Text = .Cells(m, 4)
'etc
end if
end with
End Sub
Looping through 60,000 rows of data will be slow. Why don't you try Range.Find() instead? The documentation is here https://learn.microsoft.com/en-us/office/vba/api/excel.range.find
A sample code from that page is
With Worksheets(1).Range("a1:a500")
Set c = .Find(2, lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
End With
In your code you could do something like the following. Declare a range variable and set it to the result of the find command. From the found range you can offset to the desired columns to retrieve their values.
dim result as range
x = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row
set result = Sheets("Clients").Range("A1:A" & x).Find(TextBox1.Value, lookin:=xlValues)
if not result is nothing then
TextBox1.Text = result.value
TextBox4.Text = result.offset(0,2).value
' and so on. use offset to get results from other columns in the row where the found range is
end if
I was creating a macro to reverse the capitalization of cell values, to explain better.
Original values-
hh3crd220
xmi4Idc200
TEst02NoW
Output-
HH3CRD220
XMI4iDC200
teST02nOw
I think there must already be macros which would do the job, but i was coding one myself, everything works fine except changing the nth value, Mid is not working since it will only extract the value, i tried Character but that will only format the element, i wanted something like character.value or mid.value function to work.
Sub CapsChange()
Dim letr As String
Dim Val1 As String
Dim sr As Range
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Set sr = Range("A1:A" & lastrow)
For Each r In sr
Fval = r.Value
Val1 = Left(r.Value, 1)
If Val1 <> UCase(Val1) Then
For i = 1 To Len(Fval)
letr = Mid(Fval, i, 1)
If letr = UCase(letr) Then
**'First Code try**
letr = LCase(letr)
**'Second Code try**
r.Characters(i, 1).Value = LCase(letr)
Else
letr = UCase(letr)
r.Characters(i, 1).Value = UCase(letr)
End If
Next i
End If
Next
End Sub
Just Need Help changing/controlling the nth character of cell value, like we use cell(x,y).value = XXX.
try this:
variant 1 using SUB()
Sub Test()
Dim rng As Range, cl As Range, i&
Set rng = Range("A1:A" & Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row)
For Each cl In rng.Cells
For i = Len(cl.Value) To 1 Step -1
With cl.Characters(i, 1)
If .Text = UCase(.Text) Then
.Text = LCase(.Text)
ElseIf .Text = LCase(.Text) Then
.Text = UCase(.Text)
End If
End With
Next i, cl
End Sub
variant 2 using Function()
Public Function ReverseCase(cl As Range)
Dim StringOutput$, i&
For i = Len(cl.Value) To 1 Step -1
With cl.Characters(i, 1)
If .Text = UCase(.Text) Then
StringOutput = LCase(.Text) & StringOutput
ElseIf .Text = LCase(.Text) Then
StringOutput = UCase(.Text) & StringOutput
End If
End With
Next i
ReverseCase = StringOutput
End Function
test for function()
both variants are tested, works fine
You can use the Mid statement , which allows in place modification of a string:
Sub CapsChange()
Dim letr As String
Dim Val1 As String
Dim sr As Range
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Set sr = Range("A1:A" & lastrow)
For Each r In sr
Fval = r.Value
Val1 = Left(r.Value, 1)
If Val1 <> UCase(Val1) Then
For i = 1 To Len(Fval)
letr = Mid(Fval, i, 1)
If letr = UCase(letr) Then
Mid(Fval,i,1) = LCase(letr)
else
Mid(Fval,i,1) = UCase(letr)
End If
Next i
End If
Next
End Sub
Something like the below function would be far easier to re-use!
Here is how to use it :
Option Explicit
Sub test_Angad_Arora()
Dim wS As Worksheet, _
LastRow As Long, _
i As Long
Set wS = ActiveSheet
With wS
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
.Cells(i, 1) = InvertCaseCore(.Cells(i, 1))
Next i
End With
End Sub
And the function that invert the capatilization of the inputed string:
Public Function InvertCaseCore(StringToReCapitalize As String)
Dim l As Integer, _
c As String, _
OutPut As String, _
i As Integer
l = Len(StringToReCapitalize)
For i = 1 To l
c = Mid(StringToReCapitalize, i, 1)
If (c >= "A") And (c <= "Z") Then
c = LCase(c)
ElseIf (c >= "a") And (c <= "z") Then
c = UCase(c)
End If
OutPut = OutPut & c
Next i
InvertCaseCore = OutPut
End Function
You're looking for the replace-Function (See this link).
An example:
Replace("abCabCde", "C", "c", , 1)
This will find the first (and only the first) occurrence of "C" in "abCabCde" and replaces it with "c" to get "abcabCde".
What I am doing is search some strings one by one in the entire range - like search for "blah1", if found then exit, else search "blah2" in the entire range in the same manner. "blah's" are searched in one column.
Right now i am just running a For loop code as shown below which so far works ok in my tests...but was wondering if MATCH, FIND or other methods may be faster...any opinion?
Sub test()
Dim LR As Long
LR = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
If Cells(1, "B") = "" Then
For i = 1 To LR
If Cells(i, "A") = "blah1" Then
Cells(1, "B") = Cells(i, "A").Row
Cells(1, "C") = Cells(i, "A")
Exit For
End If
Next i
End If
If Cells(1, "B") = "" Then
For i = 1 To LR
If Cells(i, "A") = "blah2" Then
Cells(1, "B") = Cells(i, "A").Row
Cells(1, "C") = Cells(i, "A")
Exit For
End If
Next i
End If
End Sub
Try this one. Since your code is repeated (for "blah1" and "blah2") I used additional function:
Sub test()
If Sheet1.Cells(1, "B") = "" Then
If findString("blah1") Then Exit Sub
If findString("blah2") Then Exit Sub
End If
End Sub
'Function findString returns TRUE if something found and FALSE otherwise
Function findString(searchString As String) As Boolean
Dim rng As Range, res
With Sheet1
Set rng = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
res = Application.Match(searchString, rng, 0)
'Application.Match returns error if nothing found
findString = Not IsError(res)
If findString Then
.Cells(1, "B").Value = rng.Cells(res, 1).Row
.Cells(1, "C").Value = searchString
End If
End With
End Function
I'm reasonably new to Excel Vba, but my limited understanding is that reading from cells is relatively slow. If I were doing this I would read all the values into an array, and carry out the same for loop as you have used, but on the array, rather than cell values.
To confirm, you could use VBAs Timer function to check speed.
Let me know if you'd like more detailed explanations of how to do this.
Here's how you can turn a range into an array (and vice versa). Step through this code with the Locals window turned on and watch what happens. You are particularly interested in the astrArray variable.
Sub ChangeArray()
'
Dim astrArray As Variant
'
' Dim astrArray
' that is, with no type specified
' is exactly equivalent
'
Dim lngIndex As Long
Dim strMessage As String
'
Range("A1").Value = "This"
Range("A2").Value = "is"
Range("A3").Value = "only"
Range("A4").Value = "a"
Range("A5").Value = "test"
astrArray = Range("A1:A5")
For lngIndex = 1 To 5
strMessage = strMessage & astrArray(lngIndex, 1) & " "
Select Case lngIndex
Case 1
astrArray(lngIndex, 1) = "No,"
Case 2
astrArray(lngIndex, 1) = "it's"
Case 3
astrArray(lngIndex, 1) = "actually"
Case 4
astrArray(lngIndex, 1) = "real"
Case 5
astrArray(lngIndex, 1) = "life"
End Select
Next lngIndex
MsgBox strMessage
Range("A1:A5") = astrArray
End Sub
A key requirement: to do this, the variable must be DIMmed Variant!
Another thing to pay attention to: the variable is two-dimensional, even though the range selected is one-dimensional.