I've set up a two-dimensional array, and I want to count the number of filled cells in column H for each trial in each block. I then want to print the number of filled cells next to the last row of data for each trial, into column T.
The problem I'm getting is that when I try to run the macro, Excel stops responding, and after restarting, I get the error message in the title.
Here is the code:
Sub dotcountanalysis2()
' create multidimensional array
Dim Participant() As Variant
Participant = Worksheets("full test").Range("A7", Range("S:S")).Value
Dim Block As Variant
Block = Columns(2)
Dim Trial As Variant
Trial = Columns(3)
' define column H as boolean variable
Dim Pressed As Boolean
Pressed = True
' begin analysis after practice trials
For Each Block In Participant
For Each Trial In Participant
pressedcount = Range("H:H").Cells.SpecialCells(xlCellTypeConstants).Count
If Cells(, 8) = Pressed Then
Range("T:T").Value = pressedcount
End If
Next Trial
Next Block
End Sub
The error is on line:
pressedcount = Range("H:H").Cells.SpecialCells(xlCellTypeConstants).Count
I'm also not sure that my syntax is correct to make it count for each trial, as I have tried stepping into the code, and it gives the total number of filled cells in column H (562), and prints it in every cell in column T. I think it's also going way past the 7011 rows of data I have, to the maximum possible number of rows.
Here is a sample of my data
The most relevant problem is probably the fact that you create a huge variant array of values and then loop two times through it's values.
The Participant array contains 1048576*19 = 19922944 values. (assuming 1048576 rows in your sheet)
Now you loop through these values and for every value you loop through each value again, giving you 19922944*19922944 = 396923697627136 iterations. So that's why excel doesn't respond.
However, within each iteration, you don't even use the value...?
If you want to calculate that number of Pressed in column H and write that number to column T, why would you load all values of columns A to S into the array?
Here is what I would do in VBA
Dim pressedCount As Long
Dim myCell As range
Dim pressedRange As range
With Worksheets("full test")
pressedCount = Application.WorksheetFunction.CountA(.Columns("H"))
If pressedCount = 0 Then Exit Sub 'make sure there are cells or else the next line will fail
Set pressedRange = .Columns("H").SpecialCells(xlCellTypeConstants)
For Each myCell In pressedRange.Cells 'only loop through the cells containing something
.Cells(myCell.Row, "T").Value = pressedCount
Next myCell
End With
I used the With block so I don't have to write the sheet before every range which you should because otherwise it assumes you mean the active sheet.
Note that this assumes that there can be no other values than "Pressed" in column H, not even a header. If there is a header, start at row 2 and use .Range(.Cells(2, "H"), .Cells(.Rows.Count, "H")) instead of .Columns("H")
However this could also be achieved using a Formula like =IF($H7="Pressed",COUNTA(H:H),"")
Related
Am trying to make a VBA validation sheet on Excel to find all the cells that do not match a predefined pattern and copy it to another sheet
My pattern is "4 numbers/5 numbers"
Ex: 1234/12345 is accepted
2062/67943 is accepted
372/13333 is not accepted
1234/1234 is not accepted etc...
I tried to put the following in the conditions sheet : <>****/***** and <>????/????? and both did not work (am not sure about the correctness of the approach as am still a beginner in VBA)
For the code itself, this is what I wrote :
Sub GuaranteeElig()
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = SheetName
Sheets("MainSheet").UsedRange.AdvancedFilter Action:= _
xlFilterCopy,
CriteriaRange:=Sheets("ConditionsSheet").Range("B1:B2"), _
CopyToRange:=Range("A1"), Unique:=False
End Sub
Any tips on how I can do it ?
Thanks in advance :)
As long as the values of the numbers are independent and do not matter, and it is only the Length of the numerical strings that count, you could use a for loop on the cells from the "search" sheet (I assume this is the MainSheet as shown in your code?) where your values are contained.
From there, I'll give you a couple ways to place the data in the validation sheet (assuming this is your ConditionsSheet as shown in your code?) where you are trying to pinpoint the values.
(You may need to change part of your approach depending on how you want the incorrect set of values laid out on your secondary sheet - but this should get you started.) I added a TON of comments as you say you're new to VBA - these will help you understand what is being done.
Sub GuaranteeElig()
'Adding this to help with performance:
Application.ScreenUpdating = False
'Assuming you are adding a sheet here to work with your found criteria.
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ConditionsSheet"
'Using the naming bits below I am assuming the data you are searching for is on MainSheet
'Get used range (most accurate and efficient way I have found yet, others on S.O.
'may have better ways for this - research it if this does not work for you)
'I have had problems using the Sheets().UsedRange method.
Dim c as Long 'This may not be necessary for you if you are looping through only column "A"
Dim r as Long
'Cells(y,x) method uses numerical values for each row (y) or column (x).
c = Cells(1, Columns.Count).End(xlToLeft).Column 'May not be necessary depending on your needs.
'Using this because you have "UsedRange" in your
'code.
'.End(xlToLeft) signifies we are going to the end of the available cell range of
'Row 1 and then performing a "Ctrl+Left Arrow" to skip all blank cells until we hit
'the first non-blank cell.
r = Cells(Rows.Count, 1).End(xlUp).Row
'.End(xlUp) method is similar - we go to the end of the available cell range for the
'column ("A" in this case), then performing a "Ctrl+Up Arrow" to skip all blank cells.
'If you have a header row which spans across the sheet, this is your best option,
'unless you have 'helper' cells which extend beyond the final column of this header
'row. I am assuming Row 1 is a header in this case - change to your needs.
'For your Rows - choose the column which contains congruent data to the bottom of
'your used range - I will assume column 1 in this case - change to suit your needs.
Dim i as long
Dim j as integer
Dim cel as Range
Dim working_Str() as String 'String Array to use later
Dim string1 as String
Dim string2 as String
Dim badString as Boolean
For i = 2 to r Step 1 'Step down from row 2 to the end of data 1 Row at a time
'Row 1 is header.
set cel=Cells(i, 1) 'Sets the cell to check - assuming data is in Column "A"
'i will change from for loop so 'cel' changes from "A2555"
'to "A2554" to "A2553" etc.
working_Str=Split(cel.Value, "/", -1) 'Splits the value based on "/" inside of cel
string1=working_Str(0) 'what we hope will always be 4 digits
string2=working_Str(1) 'what we hope will always be 5 digits
If Len(string1)<>4 Then 'string1 _(xxxx)_(/)(don't care) does not equal 4 digits in length
badString = True
Elseif Len(string2)<>5 Then ''string1 (don't care)(/)_(xxxxx)_ does not equal 5 digits in length
badString = True
End If
If badString Then 'If either strings above were not correct length, then
'We will copy cell value over to the new sheet "ConditionsSheet"
'Comment the next 2 commands to change from going to one row at a time to
'Matching same row/Cell on the 2nd sheet. Change to suit your needs.
j = j + 1 'Counter to move through the cells as you go, only moving one cell
'at a time as you find incorrect values.
Sheets("ConditionsSheet").Range("A" & j).Value=cel.Value 'sets the value on other sheet
'UNComment the next command to change from going to one row at a time to
'matching same row/cell on the 2nd sheet. Change to suit your needs.
'Sheets("ConditionsSheet").Range("A" & i).Value=cel.Value
End if
badString = False 'resets your boolean so it will not fail next check if strings are correct
Next i
'Returning ScreenUpdating back to True to prevent Excel from suppressing screen updates
Application.ScreenUpdating = True
End Sub
UPDATE
Check the beginning and ending lines I just added into the subroutine. Application.ScreenUpdating will suppress or show the changes as they happen - suppressing them makes it go MUCH quicker. You also do not want to leave this setting disabled, as it will prevent Excel from showing updates as you try to work in the cell (like editing cell values, scrolling etc. . . Learned the hard way. . .)
Also, if you have a lot of records in the given row, you could try putting the data into an array first. There is a great example here at this StackOverflow Article.
Accessing the values of a range across multiple rows takes a LOT of bandwidth, so porting the range into an Array first will make this go much quicker, but it still may take a bit. Additionally, how you access the array information will be a little different, but it'll make sense as you research it a little more.
Alternative To VBA
If you want to try using a formula instead, you can use this - just modify for the range you are looking to search. This will potentially take longer depending on processing speed. I am entering the formula on 'Sheet2' and accessing 'Sheet1'
=IF(COUNTIF(Sheet1!A1,"????/?????"),1,0)
You are spot on with the search pattern you want to use, you just need to use a function which uses wildcard characters within an "if" function. What you do with the "If value is true" vs "If value is false" bits are up to you. COUNTIF will parse wildcards, so if it is able to "count" the cell matching this string combination, it will result in a "True" value for your if statement.
Regex method, this will dump the mismatched value in a worksheet named Result, change the input range and worksheet name accordingly.
In my testing, 72k cells in UsedRange takes about 4seconds~:
Option Explicit
Sub GuaranteeElig()
Const outputSheetName As String = "Result"
Dim testValues As Variant
testValues = ThisWorkbook.Worksheets("MainSheet").UsedRange.Value 'Input Range, change accordingly
Const numPattern As String = "[\d]{4}\/[\d]{5}"
Dim regex As Object
Set regex = CreateObject("VBScript.Regexp")
regex.Pattern = numPattern
Dim i As Long
Dim n As Long
Dim failValues As Collection
Set failValues = New Collection
'Loop through all the values and test if it fits the regex pattern - 4 digits + / + 5 digits
'Add the value to failValues collection if it fails the test.
For i = LBound(testValues, 1) To UBound(testValues, 1)
For n = LBound(testValues, 2) To UBound(testValues, 2)
If Not regex.Test(testValues(i, n)) Then failValues.Add testValues(i, n)
Next n
Next i
Erase testValues
Set regex = Nothing
If failValues.Count <> 0 Then
'If there are mismatched value(s) found
'Tranfer the values to an array for easy output later
Dim outputArr() As String
ReDim outputArr(1 To failValues.Count, 1 To 1) As String
For i = 1 To failValues.Count
outputArr(i, 1) = failValues(i)
Next i
'Test if output worksheet exist
Dim outputWS As Worksheet
On Error Resume Next
Set outputWS = ThisWorkbook.Worksheets(outputSheetName)
On Error GoTo 0
'If output worksheet doesn't exist, create a new sheet else clear the first column for array dump
If outputWS Is Nothing Then
Set outputWS = ThisWorkbook.Worksheets.Add
outputWS.Name = outputSheetName
Else
outputWS.Columns(1).Clear
End If
'Dump the array starting from cell A1
outputWS.Cells(1, 1).Resize(UBound(outputArr, 1)).Value = outputArr
Else
MsgBox "No mismatched value found in range"
End If
Set failValues = Nothing
End Sub
If you do not need duplicate values in the list of mismatched (i.e. unique values) then sound out in the comment.
If cell in Range("H1:H104000") is "" Then
Range("H1:H104000) = LEFT(Range("D1:D104000), 3
End If
This is the code I am trying with no success.
You're missing the Loop. You need to write the loop to iterate through the collection of cells, the code can't do it implicitly even if you compare a single range to a collection of ranges.
Also, to compare values use =. The Is operator is only used for Objects.
Dim Cell As Range
For Each Cell In Range("H1:H104000").Cells
If Cell.Value = "" Then
Cell.Value = Right(Cell.Offset(0, -4).Value, 3)
End If
Next
Once you're iterating through the column H. An easy way to refer to "column D in the current row" is by using Offset, which will return a cell, relative to your given starting position. In this case, we just need to move 4 columns to the left so I do .Offset(0,-4)
You might consider
assigning a worksheet related formula evaluation to a variant datafield array data and
writing data back to the referenced column H instead of looping through the given range; this approach lasts only a fraction of a second while the loop through each cell by means of VBA needs several seconds:
Option Explicit ' head of code module
Sub ExampleCall()
Dim t As Double: t = Timer ' start timer
Dim ws As Worksheet
Set ws = Sheet1 ' << change to your project's sheet Code(Name)
Dim data As Variant ' provide for a 1-based 2-dim datafield array
'assign worksheet related evaluation to data
data = ws.Evaluate("=If(IsBlank(H2:H104000),Right(D2:D104000,3),H2:H104000)")
'write to target
ws.Range("H2").Resize(UBound(data), 1).Value = data
Debug.Print Format(Timer - t, "0.00 secs") ' 0.20 secs
End Sub
Further note A worksheet related evaluation via ws.Evaluate(...) guarantees a fully qualified range reference, whereas Evaluate(...) would need more detailed range indications like Sheet1!H2:H104000 or a further textual insertion of ws.Range("H2:H104000").Address(External:=True) to the formula string.
I have several sheets containing ListObjects
When I have to look for corresponding values in a listbject what I do is the following:
dim mytable as Listobject
set mytable = thisworkbook.sheets(x).listobject(1)
ValuetoSearch="whatever"
valueResult=""
' looking for the corresponding value of column A in column B
for i=1 to mytable.listrows.count
if mytable.listcolumns("A").databodyrange.item(i).value=ValuetoSearch then
valueResult=mytable.listcolumns("B").databodyrange.item(i).value
exit for
end if
next i
That works. fine.
but:
Its that the FASTEST way to do the search?
I am using several of those lookup operations "on the fly" when the user select certain cells in the sheet (with workbook change select) and it comes a point when "you feel it" there is this almost a second delay that starts to be annoying for the user.
cheers
thanks
One of the major slow-downs in VBA is reading/writing cell values. You want to minimize the number of times you read/write to a worksheet as much as possible. As it turns out, in most cases it's much, much faster to read a range of values into an array, then do calculations on that array, than it is to do the same calculations on the range of values itself.
In your case, you could read the range of the table into an array (only one read operation), instead of doing a read operation for each row.
Dim mytable As ListObject
Dim myArr() As Variant
Set mytable = ThisWorkbook.Sheets(x).ListObject(1)
valuetosearch = "whatever"
valueResult = ""
myArr = mytable.Range.Value 'Read entire range of values into array
' looking for the corresponding value of column A in column B
For i = 1 To mytable.ListRows.Count
If myArr(i, 1) = valuetosearch Then 'Check the value of the ith row, 1st column
valueResult = myArr(i,2) 'Get the value of the ith row, 2nd column
Exit For
End If
Next i
I ran a quick benchmark on a table with 1,000,000 rows, and with the searched value only appearing in the very last row (worst possible case). Your original code takes 4.201 seconds, and this one takes 0.484 seconds. That's nearly 9 times faster!
If your data is on a worksheet then Application.Match() is very fast:
Sub Tester()
Dim m, rng, t
Set rng = ThisWorkbook.Sheets(1).ListObjects(1).ListColumns(1).DataBodyRange
t = Timer()
m = Application.Match("Val_1", rng, 0) 'on the first row...
Debug.Print m, Timer - t 'approx 0 sec
t = Timer()
m = Application.Match("Val_1000000", rng, 0) 'on the last row...
Debug.Print m, Timer - t 'approx 0.03 to 0.05 sec
End Sub
m will either be the index of the matched row, or an error if there's no match - you can test for that using IsError(m)
I have written VBA code that copies a filtered table from one spreadsheet to another. This is the code:
Option Explicit
Public Sub LeadingRetailers()
Dim rngRows As Range
Set rngRows = Worksheets("StoreDatabase").Range("B5:N584")
With rngRows
.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Worksheets("LeadingRetailersAUX").Range("B2")
End With
Sheets("Leading Retailers").Activate
End Sub
The filter is applied before the code is ran and then the code selects the visible cells and copies them so as to get only those rows that passed the filter.
In the filtered table to be copied I have, in column L of the range, a certain set of names, some of which are repeated in several rows.
I would like to add to the code so that it only copies one row per name in column L. In other words, I would like the code to copy only the first row for each of the names that appears in Column L of the filtered table.
Pehaps something like this can help you. Code will loop through your rows (5 to 584). First it checks if row is hidden. If not, will check if the value in column "L" is already in the Dictionary. If it is not, it will do two things: copy the row to Destination Sheet, and add the value to the Dictionary.
Option Explicit
Public Sub LeadingRetailers()
Dim d As Object
Dim i As Long
Dim k As Long
Set d = CreateObject("scripting.dictionary")
i = 2 'first row of pasting (in "LeadingRetailersAUX")
For k = 5 To 584
If Not (Worksheets("StoreDatabase").Rows(k).RowHeight = 0) Then 'if not hidden
If Not d.Exists(Worksheets("Hoja1").Cells(k, 12).Value) Then 'if not in Dictionary
d.Add Worksheets("StoreDatabase").Cells(k, 12).Value, i 'Add it
Worksheets("LeadingRetailersAUX").Cells(i, 2).EntireRow.Value = Worksheets("StoreDatabase").Cells(k, 1).EntireRow.Value
i = i + 1
End If
End If
Next
End Sub
You could apply another filter to the table to only show the first occurrence of each set of names and then run your macro as usual. See this answer:
https://superuser.com/a/634284
Currently I have a medical spread-sheet with a list of clients that we have serviced. We have 8 different clinical categories which are denoted by different acronyms - HV,SV,CV,WV,CC,OV,TS and GS.
A client can receive multiple therapies i.e. HV,SV,CV - in the background we have a counter mechanism which would increment each of these records by 1.The formula used for this counter is:
=(LEN('Parent Sheet'!F25)-LEN(SUBSTITUTE('Parent Sheet'!F25,'Parent Sheet'!$P$4,"")))/LEN('Parent Sheet'!$P$4)
At the bottom of the sheet we then have a sum which ads up all the treatments that occurred for that week.
Now the tricky part about this is that we have almost a year's worth of data in this sheet but the summing formulas are set as: SUM(COLUMN 6: COLUMN 53) but due to a need to increase the entries beyond this limit, we have to adjust the sum formula. We have 300 SUM Formulas adding up each of the 8 Criteria items and assigning them to the HV,SV,SC,WV etc. counters.
Would we have to adjust this manually one by one or is there a easier way of doing this?
Thank you very much!
To me, I think you should change the sheet layout a little, create a User Defined Function (UDF) and alter the formulas in your Sum rows for efficient row/column adding (to make use of Excel's formula fill). The only issue is that you need to save this as a Macro-Enabled file.
What you need to change in the formulas is to utilize $ to restrict changes in column and rows when the formula fill takes place.
To illustrate in an example, consider:
Assuming the first data starts at row 6, and no more than row 15 (you can use the idea of another data gap on the top). Alter the Sum row titles to begin with the abbreviation then create a UDF like below:
Option Explicit
' The oRngType refers to a cell where the abbreviation is stored
' The oRngCount refers to cells that the abbreviation is to be counted
' Say "HV" is stored in $C16, and the cells to count for HV is D$6:D$15,
' then the sum of HV for that date (D16) is calculated by formula
' `=CountType($C16, D$6:D$15)`
Function CountType(ByRef oRngType As Range, ByRef oRngCount) As Long
Dim oRngVal As Variant, oVal As Variant, oTmp As Variant, sLookFor As String, count As Long
sLookFor = Left(oRngType.Value, 2)
oRngVal = oRngCount.Value ' Load all the values onto memory
count = 0
For Each oVal In oRngVal
If Not IsEmpty(oVal) Then
For Each oTmp In Split(oVal, ",")
If InStr(1, oTmp, sLookFor, vbTextCompare) > 0 Then count = count + 1
Next
End If
Next
CountType = count
End Function
Formulas in the sheet:
Columns to sum are fixed to rows 6 to 15 and Type to lookup is fixed to Column C
D16 | =CountType($C16,D$6:D$15)
D17 | =CountType($C17,D$6:D$15)
...
E16 | =CountType($C16,E$6:E$15)
E17 | =CountType($C17,E$6:E$15)
The way I created the UDF is to lookup and count appearances of a cell value (first argument) within a range of cells (second argument). So you can use it to count a type of treatment for a big range of cells (column G).
Now if you add many columns after F, you just need to use the AutoFill and the appropriate rows and columns will be there.
You can also create another VBA Sub to add rows and columns and formulas for you, but that's a different question.
It's isn't a great idea to have 300 sum formulas.
Name your data range and include that inside the SUM formula. So each time the NAMED data range expands, the sum gets calculated based on that. Here's how to create a dynamic named rnage.
Sorry I just saw your comment. Following is a simple/crude VBA snippet.
Range("B3:F12") is rangeValue; Range("C18") is rngTotal.
Option Explicit
Sub SumAll()
Dim WS As Worksheet
Dim rngSum As Range
Dim rngData As Range
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim varSum As Variant
'assuming that your said mechanism increases the data range by 1 row
Set WS = ThisWorkbook.Sheets("Sheet2")
Set rngData = WS.Range("valueRange")
Set rngSum = WS.Range("rngTotal")
colCount = rngData.Columns.Count
'to take the newly added row (by your internal mechanism) into consideration
rowCount = rngData.Rows.Count + 1
ReDim varSum(0 To colCount)
For i = 0 To UBound(varSum, 1)
varSum(i) = Application.Sum(rngData.Resize(rowCount, 1).Offset(, i))
Next i
'transpose variant array with totals to sheet range
rngSum.Resize(colCount, 1).Value = Application.Transpose(varSum)
'release objects in the memory
Set rngSum = Nothing
Set rngData = Nothing
Set WS = Nothing
Set varSum = Nothing
End Sub
Screen:
You can use named ranges as suggested by bonCodigo or you could use find and replace or you can insert the columns within the data range and Excel will update the formula for you automatically.