I recently got into Excel macro development after a long time of not having the need to.
I have one column with two-hundred rows where each row has a value. I wrote a loop to iterate to each row value, read the current value and then write the value back minus the last character.
Here is some actual (and pseudo) code of what I wrote.
Dim theRow as Long
Dim totRow as Long
Dim fooStr as String
theRow = 2 'we begin on the second row of the colummn
totRow = 201 'there are 200 values
For theRow = 2 to totRow
fooStr = WorkSheets(DestSheet).Cells(theRow,"A").Formula 'read the cell value
fooStr = Left(fooStr,Len(fooStr)-1 'subtract the last character from the value
Cells(theRow,1).Value = fooStr 'write the value back
Next theRow
After I did some reading I learned that it is best practice to read and write values using a Range. Is it possible to rewrite what I am doing using a Range so it willl go faster.
Here is what I came up with so far.
Range("A2:A201").Value = Len(Range.Left("A2:A201").Value)-1
However, this doesn't work.
Any clues on how to do this if this is indeed possible?
Thanks for any tips.
If you want maximum performance (you don't need it for 200 rows, but...) you have to minimize the number of reads and writes (mostly writes) to ranges. That means reading the whole range into an array, manipulating the array, then writing it back to the range. That's one read and one write compared to 200 in a loop. Here's an example.
Sub RemoveLastChar()
Dim vaValues As Variant
Dim i As Long
vaValues = Sheet1.Range("A2").Resize(200).Value
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
vaValues(i, 1) = Left$(vaValues(i, 1), Len(vaValues(i, 1)) - 1)
Next i
Sheet1.Range("A2").Resize(UBound(vaValues, 1), UBound(vaValues, 2)).Value = vaValues
End Sub
You could do something like
Sub StringTrim()
Dim xCell as Range
Range("A1:A201").Select
For Each xCell in Selection
xCell.Value = Left(xCell.Value, Len(xCell.Value) - 1)
Next
End Sub
I don't know what kind of speed improvements you are seeking, but that would also do the job.
You might know this already but putting Application.ScreenUpdating = False at the top of your code can speed it up significantly (unless you like to watch everything flash by as the script works). You should reset the value to True at the end of your code.
Related
Let's say I have very large set of data with over 100,000+ rows. In Column A, I want to find each unique number.
I understand this can be done using the .Find feature and Collections/Arrays but those seem to take a good bit of time - especially with 100,000+ rows.
However, after AutoFiltering Column A, when I hit the down arrow it displays only unique variables. Is it possible to simply extract those values out of the selections in this way?
'pseudocode
filter.Count
Dim X As Long
For x = 2 to filter.Count
Cells(x, 14) = filter(x)
Next x
You can use advanced filter, it's pretty darn quick. I tried it with 127k rows, the results were instant.
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
You can extract the visible cells in to an array. Say your total range (without filter) is A2:A10000. Run your filter, then you can run this macro:
Sub t()
Dim arr() As Variant
arr = Range("A2:A10000").SpecialCells(xlCellTypeVisible)
Dim i As Long
For i = LBound(arr) To UBound(arr)
Debug.Print (arr(i, 1))
' Do things with each entry in array
Next i
End Sub
I'm attempting to use a Scripting Dictionary in a way as to be able to find and ultimately highlight same values or groups of same values where there are inconsistencies (ie blanks or different values in between the two same values or groups of same values). Normally these same values will repeat, but what I'm trying to catch is when they do not repeat together (See example image below taken from my previous post).
Some context that will hopefully help this make a little more sense:
This is a follow-up of sorts to one of my previous questions here. I have a conditional formatting formula:
=NOT(AND(IFERROR(COUNTIF(OFFSET(A1,0,0,-COUNTIF($A$1:$A1,A2)),A2),0)=IFERROR(COUNTIF($A$1:$A1,A2),0),IFERROR(COUNTIF(OFFSET(A3,0,0,COUNTIF($A3:$A$5422,A2)),A2),0)=IFERROR(COUNTIF($A3:$A$5422,A2),0),A2<>""))
Which works perfectly. However, in my tinkering after receiving this formula as the answer to that previous question I realized that using conditional formatting of any sort for the amount of data I typically deal with (15000+ rows with 140 consistent columns) is an extremely slow endeavor, both when applying the formula and when filtering/adjusting afterwards. I've also tried applying this formula via the "helper column" route, but to no surprise, that is just as slow.
So, where I'm at now:
Essentially, I'm trying to translate that formula into a piece of code that does the same thing, but more efficiently, so that's where I starting thinking to use a Scripting Dictionary as a way to speed up my code execution time. I have the steps outlined, so I know what I need to do. However, I feel as though I am executing it wrong, which is why I'm here to ask for assistance. The following is my attempt at using a Scripting Dictionary to accomplish highlighting inconsistencies in Column A (my target column) along with the steps I figured out that I need to do to accomplish the task:
'dump column A into Array
'(Using Scripting.Dictionary) While cycling through check if duplicate
'IF duplicate check to make sure there is the same value either/or/both in the contiguous slot before/after the one being checked
'If not, then save this value (so we can go back and highlight all instances of this value at the end)
'Cycle through all trouble values and highlight all of their instances.
Sub NewandImprovedXIDCheck()
Dim d As Long, str As String, columnA As Variant
Dim dXIDs As Object
Application.ScreenUpdating = False
Set dXIDs = CreateObject("Scripting.Dictionary")
dXIDs.comparemode = vbTextCompare
With ActiveSheet
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
'.Value2 is faster than using .Value
columnA = .Columns(1).Value2
For d = LBound(columnA, 1) To UBound(columnA, 1)
str = columnA(d, 1)
If dXIDs.exists(str) Then
'the key exists in the dictionary
'Check if beside its like counterparts
If Not UBound(columnA, 1) Then
If (str <> columnA(d - 1, 1) And str <> columnA(d + 1, 1)) Or str <> columnA(d - 1, 1) Or str <> columnA(d + 1, 1) Then
'append the current row
dXIDs.Item(str) = dXIDs.Item(str) & Chr(44) & "A" & d
End If
End If
Else
'the key does not exist in the dictionary; store the current row
dXIDs.Add Key:=str, Item:="A" & d
End If
Next d
'reuse a variant var to provide row highlighting
Erase columnA
For Each columnA In dXIDs.keys
'if there is more than a single cell address, highlight all
If CBool(InStr(1, dXIDs.Item(columnA), Chr(44))) Then _
.Range(dXIDs.Item(columnA)).Interior.Color = vbRed
Next columnA
End With
End With
End With
dXIDs.RemoveAll: Set dXIDs = Nothing
Application.ScreenUpdating = True
End Sub
I feel like my logic is going wrong somewhere in my code execution, but can't seem to pinpoint where or how to correct it. Any help would be greatly appreciated. If you can provide any sort of code snippet that would also be a great help.
Here's one approach:
Sub HiliteIfGaps()
Dim rng As Range, arr, r As Long, dict As Object, v
Dim num As Long, num2 As Long
Set dict = CreateObject("scripting.dictionary")
With ActiveSheet
Set rng = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp))
End With
arr = rng.Value
For r = 1 To UBound(arr, 1)
v = arr(r, 1)
If Len(v) > 0 Then
If Not dict.exists(v) Then
num = Application.CountIf(rng, v) 'how many in total?
'all where expected?
num2 = Application.CountIf(rng.Cells(r).Resize(num, 1), v)
dict.Add v, (num2 < num)
End If
If dict(v) Then rng.Cells(r).Interior.Color = vbRed
Else
'highlight blanks
rng.Cells(r).Interior.Color = vbRed
End If
Next r
End Sub
EDIT: every time a new value is found (i.e. not already in the dictionary) then take a count of how many of those values in total there are in the range being checked. If all of those values are contiguous then they should all be found in the range rng.Cells(r).Resize(num, 1): if we find fewer than expected (num2<num) then that means the values are not contiguous so we insert True into the dictionary entry for that value, and start highlighting that value in the column.
#Tim Williams's approach did the job perfectly! I only made one slight alteration (to suit my needs). I changed
.Cells(.Rows.Count, 1).End(xlUp) to .Range("A" & .UsedRange.Rows.count)
Just because there are instances where the bottom-most row(s) might have missing values (be blank) and in this instance I feel safe enough using the .UsedRange reference because this snippet of code is one of the very first ones ran in my overall macro, so it (.UsedRange) is more likely to be accurate. I also added a Boolean operator (xidError, set to False) to be changed to True whenever we have to highlight. After I'm done looping through the Array I check xidError and if True I prompt the user to fix the error, then end the entire macro since there's no use in continuing until this particular error is corrected.
If xidError Then
'Prompt User to fix xid problem
MsgBox ("XID Error. Please fix/remove problematic XIDs and rerun macro.")
'Stop the macro because we can't continue until the xid problem has been sorted out
End
End If
Again, much thanks to Tim for his very efficient approach!
I should note that there are related solutions to my question online but I've been unable to implement them into my own situation.
We have an .mdb database of all the products that we make. I've managed to take two criteria (Order type and Box), and print all records containing those two criteria to Excel. What I need in addition to that now is to print 30 boxes in one go as a basis for a bigger template. The labeling of these boxes usually increment (e.g. P1, P2...P30), and I'm struggling to see how I can increment the numeric portion of it to fit it into my code. Ideally, I'd like for the user to input the first and last box numbers in excel to represent the entire range (P1 and P30) and use those two values.
Sub Dan()
Dim order As String
Dim title As String 'initialize title
Dim palette As String 'intialize comment
Dim finalpalette As String
Dim finalrow As Integer 'initialize bottom-most row
Dim i As Integer
Dim Cntr As Integer
Dim LR As Integer
'Clears the contents of the last macro run
With Sheets("ALL.txt")
.Range(.Cells(6, 2), .Cells(725, 8)).ClearContents 'equates to (D2:F26)/ row, column ;Erase Columns for next macro
End With
title = Sheets("Sheet2").Range("B1").Value
palette = Sheets("Sheet2").Range("B2").Value
finalrow = Sheets("Sheet1").Range("A2").End(xlDown).Row
For i = 3 To finalrow
If Cells(i, 1) = title And Cells(i, 2) = palette Then
Cells(i, 5).Copy 'Copy ID
Sheets("ALL.txt").Range("B734").End(xlUp).Offset(1, 0).PasteSpecial
Range(Cells(i, 11), Cells(i, 14)).Copy
Sheets("ALL.txt").Range("C734").End(xlUp).Offset(1, 0).PasteSpecial
Range(Cells(i, 9), Cells(i, 10)).Copy
Sheets("ALL.txt").Range("G734").End(xlUp).Offset(1, 0).PasteSpecial
End If
Next i
End Sub
The variable I'm looking to adjust is 'palette'. I originally used it to match records to one Box (P1). What I need is to able to match records from 30 boxes (P1 to P30) in the loop. The variable 'palette' is just taking the static value of whatever is in cell B2 at the moment. I'm thinking there should be some way to type the first and last box into two cells to establish a range for the macro to iterate, or to write all the box numbers into a column and have 'palette' move down a cell each loop to take in a new Box value.
In an attempt to grab data from a column that has all 30 boxes written into 30 cells, I tried the following line of code
End If
palette = Sheets("Sheet2").Range("B2").Offset(, 1)
Next i
but it does not seem to be grabbing any value. It should be grabbing values from cells B2 to B31.
Here is some code that I changed (still no clue as to why you're breaking this up into 3 parts, seems like excel VBA is an extra step that complicates it).
thisworkbook.worksheets(1).cells(i,5) Use full references when learning VBA
let me know if this works, I don't know enough about your situation to know exactly what you need, other than what I can see you're trying to do.
Sub Dan()
Dim Order As String
Dim Title As String 'initialize title
Dim Palette As String 'intialize comment
Dim Fpalette As String
Dim Frow As Integer 'initialize bottom-most row
Dim i As Integer
Dim Cntr As Integer
Dim LR As Integer
Dim wsALL As Worksheet
'Clears the contents of the last macro run
With Sheets("ALL.txt")
.Range(.Cells(6, 2), .Cells(725, 8)).ClearContents 'equates to (D2:F26)/ row, column ;Erase Columns for next macro
End With
Title = Sheets("Sheet2").Range("B1").Value
Palette = Sheets("Sheet2").Range("B2").Value
Frow = Sheets("Sheet1").Range("A2").End(xlDown).Row
Set wsALL = Sheets("ALL.txt")
i = 2
Do While i < Frow
i = i + 1
If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1) = Title And ThisWorkbook.Worksheets("Sheet1").Cells(i, 2) = Palette Then
Sheets("Sheet1").Cells(i, 5).Copy Destination:=wsALL.Range("B734").End(xlUp).Offset(1, 0)
'wsALL.Range("B734").End(xlUp).Offset(1, 0).PasteSpecial
Sheets("Sheet1").Range(Cells(i, 11), Cells(i, 14)).Copy Destination:=wsALL.Range("C734").End(xlUp).Offset(1, 0)
'wsALL.Range("C734").End(xlUp).Offset(1, 0).PasteSpecial
Sheets("Sheet1").Range(Cells(i, 9), Cells(i, 10)).Copy Destination:=wsALL.Range("G734").End(xlUp).Offset(1, 0)
'wsALL.Range("G734").End(xlUp).Offset(1, 0).PasteSpecial
End If
Loop
End Sub
Ignore the Below, I was going to make this way more complicated than necessary. Looking at your code, be sure to reference using
Hi Joshua,
I'm not sure I completely understand what you're trying to accomplish, adding in more details such as the first macro may help in getting you a specific answer. I think possibly VBA in Excel may not be the best way. A VBA in Access sounds possible solution. But this may be of help to you.
I know you said for an end user, It would be much more complicated on your part but I've had great success using microsoft query to import data, with the correct ODBC driver "Access Database Engine" http://www.microsoft.com/en-us/download/details.aspx?id=13255 it works great now and I use it to get data from flat files then send it to SQL based on a query, but I fought with it to get it to work you will rip your hair out and it wouldn't be portable to an end user
Having a user enter a value into a specific cell could work, i.e. put a value in A1 and VBA can check that value using:
Alpha = Cells(1,1).Value
pStart = Cells(2,1).Value 'A2
pEnd = pStart + 30
In order to prevent any issues with spaces this could be done as:
set pStart = Trim(ActiveCell(2,1).Value)
Or another way is to use data validation and give users a drop down list. https://support.office.com/en-ca/article/Create-or-remove-a-drop-down-list-5a598f31-68f9-4db7-b65e-58bb342132f7
Here is the code if for either way. Notice I've made some edits, most are not essential changes, just how I write VBA. When you use the copy -> paste command it avoids the clipboard if you say .Copy Destination:= Another comment, this would be so easy in Access simply write an SQL statement and use the append feature. You say that you have a macro before this, and after this, I would say make it one (very powerful and nice) SQL statement what is run through a user form.
I'm using VBA and I would like to ask for help with regards to the Excel I have created. I want to change the background color if a cell has value and if row count is even.
Here's my code:
Sub ChangeColor()
Dim rw as Variant
Dim rng As Range
Set rng = Range("B10:H10000")
For each rw In rng.Rows
If rw.Row Mod 2 = 0 And (I dont know what to put here) Then
rw.Interior.Color = RGB (183,222,232)
End If
Next rw
End Sub
And if I may ask how do I make the process of my application faster than normal since it will slow down because of the data that has been inputted (more or less 1000 + or almost 10k).
I already solved the row count is even, kindly help me for the value.
CF should be a lot quicker than VBA for this:
The formula I chose is:
=AND(ISEVEN(ROW()),B10<>"")
I'm just wanting to run through a (large) range and replace certain values (if they're above a given max or below a given min...also one particular character) with a given replacement value.
My first thought is to simply traverse each cell and check/replace when necessary. I have a feeling this procedure would be really slow though, and I'm curious if there's a better way to accomplish this.
Any time I write code that does something similar to this in VBA I watch each cell have its value altered cell by cell and it seems like there must be better way. Thanks in advance.
edit:
I haven't even written this implementation yet because I know what the result will be and I would rather do something different if it's possible, but here's what it would look like
For something
If(Range.Value == condition)
Range.Value = replacement_value
Range = Range.Offset(a, b)
End For
Make a formula in a separate column, and then copy/paste special, values only.
= if(A2 > givenvalue; replace; if(A2< anothergivenvalue; anotherreplace; if (A2 = "particularcharacterortext"; replaceonemore; A2)))
Put the formula in an empty cell in an empty column, drag it or copy/paste to the entire column. After that, if the new values are ok, copy/paste values only to the original position.
The following VBA code provides a simple framework that you can customize to meet your needs. It incorporates many of the optimizations that have been mentioned in the comments to your question, such turning off screen updating and moving the comparison from the worksheet to an array.
You will notice that the macro does a rather large compare and replace. The data set I ran it on was 2.5 million random numbers between 1 and 1000 in the range A1:Y100000. If a number was greater than 250 and less than 500, I replaced it with 0. This required replacing 24.9 percent of all the numbers in the data set.
Sub ReplaceExample()
Dim arr() As Variant
Dim rng As Range
Dim i As Long, _
j As Long
Dim floor as Long
Dim ceiling as Long
Dim replacement_value
'assign the worksheet range to a variable
Set rng = Worksheets("Sheet2").Range("A1:Y100000")
floor = 250
ceiling = 500
replacement_value = 0
' copy the values in the worksheet range to the array
arr = rng
' turn off time-consuming external operations
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'loop through each element in the array
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
'do the comparison of the value in an array element
'with the criteria for replacing the value
If arr(i, j) > floor And arr(i, j) < ceiling Then
arr(i, j) = replacement
End If
Next j
Next i
'copy array back to worksheet range
rng = arr
'turn events back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
I did some performance testing on different alternatives for coding this simple compare and replace, with results that I would expect are consistent with VBA performance results by others. I ran each alternative 10 times, calculating the elapsed time for each run, and averaging the 10 elapsed times.
The results reveal the large impact that using arrays can have, especially when the data set is large: Compared to code that tested and changed worksheet cell values one-by-one, the array operation -- copying the data set from the worksheet into an array, comparing and changing the array values, and then writing the array results back to the worksheet -- in this case reduced average run times by 98 percent, from 3.6 minutes to 4 seconds.
While the optimizations that turned off external events made a noticeable difference in worksheet operations, with a 22 percent reduction in run times, those optimizations had very little impact when most of the computational work is array-based.