I have my below code and outer array is not comparing each value with the inner array. Outer array is comparing with the one value from the inside and moving to the next value in it.
testdata = {25,27,81,104,33,34,56,78,99,84}
testdata1 = {81,104}
For i = 0 To UBound(testdata) - 1
For j = 0 To UBound(testdata1) - 1
If testdata(i) = testdata1(j) Then
isFound = True
Call DB_Connectionwisdataflagupdation(sQuery,Para2,Para3,Para4,sValue)
'c=c+1
Exit for
End If
'isFound = True
isFound = False
Next
Next
Please help me to get the solution on this.
I made a couple minor changes to your code, mainly adjusting the indices on your For loops:
Dim i As Integer
Dim j As Integer
Dim isFound As Boolean
For i = LBound(testdata) To UBound(testdata)
For j = LBound(testdata1) To UBound(testdata1)
If testdata(i) = testdata1(j) Then
isFound = True
'Call DB_Connectionwisdataflagupdation(sQuery, Para2, Para3, Para4, sValue)
MsgBox testdata(i)
Exit For
End If
isFound = False
Next
Next
Related
I ran the below code looped for 6.5 thousand cells of criteria which are looked up against the range contained on the "LISTS" tab refered to. This range is some 20 thousand rows.
I ran the code numerous times yesterday in a test file and it ran very quickly. Maybe 2 minutes: if that.
Today, after deciding I was happy with the code, I've PASTED it (caps there because I'm wondering if that has something to do with it) into my main project.
Now when I run the code, it takes 2 hours plus!
I didn't change any of the code except for sheet names.
Does anyone know of any reason for this that I'm missing?
I'm new to VBA so I'm suspecting it's some rookie error somewhere!
Dim x As Long
x = WorksheetFunction.CountA(Columns(1))
'define string length for CELL loop
Dim char As Integer
char = Len(ActiveCell)
'define cell loop name
Dim counter As Integer
'Begin RANGE loop
For Each cell In Range("b1:b" & x)
cell.Activate
'Incorporate CELL loop
For counter = 1 To char
'Determine if numeric value present in cell = TRUE or FALSE
If IsNumeric(Right(Mid(ActiveCell, 1, counter), 1)) = True Then
ActiveCell.Offset(0, 1).Value = Right(ActiveCell.Offset(0, 0), Len(ActiveCell.Offset(0, 0)) - counter + 1)
Exit For
Else
ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 0)
End If
Next
Next
Try the code below, explanations inside the code's comments:
Dim x As Long
Dim char As Long 'define string length for CELL loop
Dim counter As Long 'define cell loop name
x = WorksheetFunction.CountA(Columns(1))
Application.ScreenUpdating = False ' will make your code run faster
Application.EnableEvents = False
'Begin RANGE loop
For Each cell In Range("b1:b" & x)
'cell.Activate ' <--- no need to Activate, realy slows down your code
'Incorporate CELL loop
For counter = 1 To char
'Determine if numeric value present in cell = TRUE or FALSE
If IsNumeric(Right(Mid(cell.Value, 1, counter), 1)) = True Then
cell.Offset(0, 1).Value = Right(cell.Value, Len(cell.Value) - counter + 1)
Exit For
Else
cell.Offset(0, 1).Value = cell.Value
End If
Next counter
Next cell
Application.ScreenUpdating = True
Application.EnableEvents = True
You need to avoid the ActiveCell, as far as it slows your code. You are looping with for-each thus you can use the variable in the loop like this:
For Each cell In Range("b1:b" & x)
For counter = 1 To char
If IsNumeric(Right(Mid(cell, 1, counter), 1)) = True Then
cell.Offset(0, 1).Value = Right(cell, Len(cell) - counter + 1)
Exit For
Else
cell.Offset(0, 1) = cell.Offset(0, 0)
End If
Next
Next
Furthermore, things like cell.Offset(0, 0) are a bit useless. If you do not need Offset, do not write it. And in general:
How to avoid using Select in Excel VBA
How To Speed Up VBA Code
Thanks to everyone who took the time to post on this one.
Turns out I'm an IDIOT!!!
The first time I ran the code, I dsiabled autocalculation, and all this time when I was re-running it, I'd commented it out.
I'm new to VBA but there's no excuse for that! Agh!
So, the fix (as suggested by others on the thread):
enter before main body of the macro:
Application.Calculation = xlCalculationManual
then after the macro, enter:
Application.Calculation = xlCalculationAutomatic
Anyone have a favorite implementation of the standard (e.g. jscript, javascript) array.slice(start,end) function in vbscript?
It seems to be commonly missed (among vbscript programmers anyway) and sharing a good implementation would help. If one doesn't show up, I guess I'll have to answer my own question and write something.
For completeness, this might be a better version:
Function Slice (aInput, Byval aStart, Byval aEnd)
If IsArray(aInput) Then
Dim i
Dim intStep
Dim arrReturn
If aStart < 0 Then
aStart = aStart + Ubound(aInput) + 1
End If
If aEnd < 0 Then
aEnd = aEnd + Ubound(aInput) + 1
End If
Redim arrReturn(Abs(aStart - aEnd))
If aStart > aEnd Then
intStep = -1
Else
intStep = 1
End If
For i = aStart To aEnd Step intStep
If Isobject(aInput(i)) Then
Set arrReturn(Abs(i-aStart)) = aInput(i)
Else
arrReturn(Abs(i-aStart)) = aInput(i)
End If
Next
Slice = arrReturn
Else
Slice = Null
End If
End Function
This avoids a number of issues with the previous answer:
No consideration of objects in the array
Negative start and end values are allowed; they count backwards from the end
If start is higher than end gives a reversed array subset
The (expensive) redim preserve is not necessary since the array is empty
A defined result is returned (Null) if the input is not an array
Uses the built-in function IsArray instead of string manipulation/comparison on the input
This is one I've used in the past:
Function Slice(arr, starting, ending)
Dim out_array
If Right(TypeName(arr), 2) = "()" Then
out_array = Array()
ReDim Preserve out_array(ending - starting)
For index = starting To ending
out_array(index - starting) = arr(index)
Next
Else
Exit Function
End If
Slice = out_array
End Function
Function Slice(arr, starting, ending)
Dim out_array
If Right(TypeName(arr), 2) = "()" Then
out_array = Array()
If ending=UBound(arr)+1 Then
actending=ending-1
ReDim Preserve out_array(actending - starting)
For index = starting To actending
out_array(index - starting) = arr(index)
Next
Else
ReDim Preserve out_array(ending - starting)
For index = starting To ending
out_array(index - starting) = arr(index)
Next
End If
Else
Exit Function
End If
Slice = out_array
End Function
So I have the script below in Execl VB that goes through the rows and deletes the ones that don't contain a certain keyword.
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
For i = 2 to ActiveSheet.UsedRange.Rows.Count
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
i = i - 1
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
End Sub
The problem is that this script takes a very long time to execute (around 8 minutes for ~73000 entries). Why is that and how would I go about improving it?
no offense to other answer, but this will only help with troubleshooting.
what you need to do is remove the the line of code
Rows(i).Delete
inside the (potentially) long running For loop is what is causing the slow down.
you need to re-write it like this...
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
Dim rng As Excel.Range
Dim arr() As Variant
Dim str As String
arr = ActiveSheet.UsedRange
Dim R As Long
For R = 1 To UBound(arr, 1) ' First array dimension is rows.
If InStr(arr(R, 1), Keyword) = 0 Then
If str <> "" Then
str = "," & str
End If
str = str & arr(R, 1).Address
End If
Next R
Set rng = ActiveSheet.Range(str)
RowsDeleted = rng.Rows.Count
rng.Delete
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
It takes ages may due to formulas in your cells that are going to be deleted.
What you should do is to turn off auto calculation and Clear the contents of that row before delete. Also you should start from bottom up!
Try this:
Sub Main()
Dim lMode As Long
' Store initial state of Calculation mode
lMode = Application.Calculation
' Change to Manual Calculation
Application.Calculation = xlCalculationManual
' Disable screen update
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
' Start from bottom up!
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).ClearContents
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
End If
Next i
' Restore screenupdate and calculation mode
Application.ScreenUpdating = True
Application.Calculation = lMode
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
Here could be something to look at,
It filters Column A for cells <>"Cola" and clears them
It then sorts column A so the blank cells in column A are now at the bottom
It then deletes the blank rows.
Not knowing the setup of the OP's ws, there may have to be adjustments made.
On my sample sheet I use 81,000 rows, when I run the code it takes about 5 seconds.
Sub SomeDeleteCode()
Dim Rws As Long, Rng As Range, nwRw As Long
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = 0
Application.Calculation = xlCalculateManual
Columns("A:A").AutoFilter Field:=1, Criteria1:="<>*Cola*"
Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
Rng.ClearContents
ActiveSheet.AutoFilterMode = 0
Columns(1).Sort Key1:=Range("A1"), Header:=xlYes
nwRw = Cells(Rows.Count, "A").End(xlUp).Row
Range(Range("B" & nwRw + 1), Range("B" & nwRw + 1).End(xlDown)).EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
End Sub
Amend your code to look like this:
Sub Main()
On Error Goto ErrHandler
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
For i = ActiveSheet.UsedRange.Rows.Count to 2
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
' i = i - 1 ' -- manually changing the loop counter is a bad idea
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
EndSub:
Application.ScreenUpdating = True
exit sub
ErrHandler:
' Error handling here
resume EndSub
End Sub
The error handler is required to ensure that the ScreenUpdating is restored, even in case of an error.
Ok so I've searched and searched and can't quite find what I'm looking for.
I have a workbook and what I'm basically trying to do is take the entries from certain ranges (Sheet1 - E4:E12, E14:E20, I4:I7, I9:I12, I14:I17, & I19:I21) and put them in a separate list on Sheet2. I then want the new list on Sheet2 to be sorted by how many times an entry appeared on Sheet1 as well as display the amount.
example http://demonik.doomdns.com/images/excel.png
Obviously as can be seen by the ranges I listed above, this sample is much smaller lol, was just having trouble trying to figure out how to describe everything and figured an image would help.
Basically I am trying to use VBA (the update would be initialized by hitting a button) to copy data from Sheet1 and put all the ranges into one list in Sheet2 that is sorted by how many times it appeared on Sheet1, and then alphabetically.
If a better discription is needed just comment and let me know, I've always been horrible at trying to describe stuff like this lol.
Thanks in advance!
Another detail: I cant have it search for specific things as the data in the ranges on Sheet1 may change. Everything must be dynamic.
I started out with this data
and used the following code to read it into an array, sort the array, and count the duplicate values, then output the result to sheet2
Sub Example()
Dim vCell As Range
Dim vRng() As Variant
Dim i As Integer
ReDim vRng(0 To 0) As Variant
Sheets("Sheet2").Cells.Delete
Sheets("Sheet1").Select
For Each vCell In ActiveSheet.UsedRange
If vCell.Value <> "" Then
ReDim Preserve vRng(0 To i) As Variant
vRng(i) = vCell.Value
i = i + 1
End If
Next
vRng = CountDuplicates(vRng)
Sheets("Sheet2").Select
Range(Cells(1, 1), Cells(UBound(vRng), UBound(vRng, 2))) = vRng
Rows(1).Insert
Range("A1:B1") = Array("Entry", "Times Entered")
ActiveSheet.UsedRange.Sort Range("B1"), xlDescending
End Sub
Function CountDuplicates(List() As Variant) As Variant()
Dim CurVal As String
Dim NxtVal As String
Dim DupCnt As Integer
Dim Result() As Variant
Dim i As Integer
Dim x As Integer
ReDim Result(1 To 2, 0 To 0) As Variant
List = SortAZ(List)
For i = 0 To UBound(List)
CurVal = List(i)
If i = UBound(List) Then
NxtVal = ""
Else
NxtVal = List(i + 1)
End If
If CurVal = NxtVal Then
DupCnt = DupCnt + 1
Else
DupCnt = DupCnt + 1
ReDim Preserve Result(1 To 2, 0 To x) As Variant
Result(1, x) = CurVal
Result(2, x) = DupCnt
x = x + 1
DupCnt = 0
End If
Next
Result = WorksheetFunction.Transpose(Result)
CountDuplicates = Result
End Function
Function SortAZ(MyArray() As Variant) As Variant()
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim x As Integer
Dim Temp As String
First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For x = i + 1 To Last
If MyArray(i) > MyArray(x) Then
Temp = MyArray(x)
MyArray(x) = MyArray(i)
MyArray(i) = Temp
End If
Next
Next
SortAZ = MyArray
End Function
End Result:
Here is a possible solution that I have started for you. What you are asking to be done gets rather complicated. Here is what I have so far:
Option Explicit
Sub test()
Dim items() As String
Dim itemCount() As String
Dim currCell As Range
Dim currString As String
Dim inArr As Boolean
Dim arrLength As Integer
Dim iterator As Integer
Dim x As Integer
Dim fullRange As Range
Set fullRange = Range("E1:E15")
iterator = 0
For Each cell In fullRange 'cycle through the range that has the values
inArr = False
For Each currString In items 'cycle through all values in array, if
'values is found in array, then inArr is set to true
If currCell.Value = currString Then 'if the value in the cell we
'are currently checking is in the array, then set inArr to true
inArr = True
End If
Next
If inArr = False Then 'if we did not find the value in the array
arrLength = arrLength + 1
ReDim Preserve items(arrLength) 'resize the array to fit the new values
items(iterator) = currCell.Value 'add the value to the array
iterator = iterator + 1
End If
Next
'This where it gets tricky. Now that you have all unique values in the array,
'you will need to count how many times each value is in the range.
'You can either make another array to hold those values or you can
'put those counts on the sheet somewhere to store them and access them later.
'This is tough stuff! It is not easy what you need to be done.
For x = 1 To UBound(items)
Next
End Sub
All that this does so far is get unique values into the array so that you can count how many times each one is in the range.
I have a list of items in an Excel worksheet, A1-B115. At the moment I can enter 10 variables which retrieves the correct data from the list.
Code now:
C1=1 - run through A1-A115 and check for the value to be between 1000-2000; if so, copy the B value somewhere.
C2=1 - run through A1-A115 and check for the value to be between 2001-3000; if so, copy the B value somewhere.
....
What I would like to do is that I can enter a value (example: 25 or 30) and that my macro randomly selects the right amount of values.
Code I would like to do: C1: 30 -> randomly selects 30 values from B1-B115
This will do the trick.
Sub PickRandomItemsFromList()
Const nItemsToPick As Long = 10
Const nItemsTotal As Long = 115
Dim rngList As Range
Dim varRandomItems() As Variant
Dim i As Long
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
varRandomItems(i) = rngList.Cells(Int(nItemsTotal * Rnd + 1), 1)
Next i
' varRandomItems now contains nItemsToPick random items from range rngList.
End Sub
As discussed in the comments, this will allow individual items to be picked more than once within the nItemsToPick picked, if for example number 63 happens to be randomly picked twice. If you don't want this to happen, then an additional loop will have to be added to check whether the item about to be picked is already in the list, for example like so:
Sub PickRandomItemsFromList()
Const nItemsToPick As Long = 10
Const nItemsTotal As Long = 115
Dim rngList As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i As Long
Dim j As Long
Dim booIndexIsUnique As Boolean
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
' It's already there.
booIndexIsUnique = False
Exit For
End If
Next j
If booIndexIsUnique = True Then
Exit Do
End If
Loop
varRandomItems(i) = rngList.Cells(idx(i), 1)
Next i
' varRandomItems now contains nItemsToPick unique random
' items from range rngList.
End Sub
Note that this will loop forever if nItemsToPick > nItemsTotal !
I would use a collection to make sure you don't get any duplicates.
Function cItemsToPick(NrOfItems As Long, NrToPick As Long) As Collection
Dim cItemsTotal As New Collection
Dim K As Long
Dim I As Long
Set cItemsToPick = New Collection
If NrToPick > NrOfItems Then Exit Function
For I = 1 To NrOfItems
cItemsTotal.Add I
Next I
For I = 1 To NrToPick
K = Int(cItemsTotal.Count * Rnd + 1)
cItemsToPick.Add cItemsTotal(K)
cItemsTotal.Remove (K)
Next I
Set cItemsTotal = Nothing
End Function
You can test this function with the following code:
Sub test()
Dim c As New Collection
Dim I As Long
Set c = cItemsToPick(240, 10)
For I = 1 To c.Count
Debug.Print c(I)
Next I
End Sub