Related
I'm a VBA noob. I need help working out this filter:
My data has ~50,000 rows and 100 columns. The column I want to filter has values like TL-98.263138472% BD-1.736861528%. I want to filter out all the values in VBA where TL>90%. I can think of a long way of doing it - where I create a loop, break down each cell, then look at TL, then the 4 numbers next to it. But it sounds like it would take forever. Wondering if there's a faster/easier way to do it? Also wondering, if it's even worth it. If it would take even more than 2 seconds, then I would rather not do it with VBA.
I have not coded it yet, wanted to see if anyone has better ideas than what I came up with.
Thanks in advance! Adding an example of my data below:
Pretty fast in my tests:
Sub tester()
Dim ws As Worksheet, t
Dim i As Long, rng As Range, rngFilt As Range, arr, arrFilt
' For i = 2 To 50000 'create some dummy data
' Cells(i, "A") = "TL-" & 50 + (Rnd() * 60) & "% BD-1.736861528%"
' Next i
' [B2:CV50000].value="blah" 'fill rest of table
t = Timer
Set ws = ActiveSheet
If ws.FilterMode Then ws.ShowAllData
Set rng = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row) 'range of values to filter
Set rngFilt = rng.Offset(0, 110) 'a range off to the right to filter on
arr = rng.Value
arrFilt = rngFilt.Value 'for holding filtering flags
arrFilt(1, 1) = "Filter" 'column header
For i = 2 To UBound(arr, 1)
arrFilt(i, 1) = IIf(FilterOut(arr(i, 1)), "Y", "N")
Next i
rngFilt.Value = arrFilt
rngFilt.AutoFilter field:=1, Criteria1:="N"
Debug.Print Timer - t
End Sub
'does this value need to be filtered out?
Function FilterOut(v) As Boolean
Dim pos As Long
pos = InStr(v, "TL-")
If pos > 0 Then
v = Mid(v, pos + 3)
pos = InStr(v, "%")
If pos > 0 Then
v = Left(v, pos - 1)
'Debug.Print v
If IsNumeric(v) Then FilterOut = v > 90
End If
End If
End Function
This ran in <0.3 sec for me, on a 50k row X 100 col dataset
Filter Via Table Helper Column and String Parse
It you want to look into non VBA solutions, You could use a helper column to decide it it's worth filtering out.
First we need to find "TL-" in the string, then find "%" After that:
MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3)
This will just return us that value sub string, regardless or position.
Now we need to convert it into a value... and I'm told that --( ) isn't the correct way to convert a string to a value... but i keep using it and it keeps working.
Anyway, finally we test if that is larger than 90 like:
=IF(--(MID(A4,FIND("TL-",A4)+3,FIND("%",A4,FIND("TL-",A4)+3)-FIND("TL-",A4)-3))>90,"Remove","Keep")
Here's my example:
And the final result.
And Filtered:
Copy Values (Efficiently!?)
The Code
Option Explicit
Sub CopyData()
Dim T As Double: T = Timer
' Read Data: Write the values from the source range to an array.
' Define constants.
Const SRC_NAME As String = "Sheet1"
Const SRC_COLUMN As Long = 44
Const CRIT_STRING_LEFT As String = "TL-"
Const CRIT_VALUE_GT As Double = 90
Const DST_NAME As String = "Sheet2"
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
' Write to the array (practically this line uses up all the time).
Dim Data(): Data = srg.Value ' assumes at least two cells in 'srg'
Debug.Print "Read Data: " & Format(Timer - T, "0.000s")
T = Timer
' Modify Data: Write the critical values to the top of the array.
Dim cLen As Long: cLen = Len(CRIT_STRING_LEFT)
Dim dr As Long: dr = 1 ' skip headers
Dim sr As Long, c As Long
Dim cPos As Long, cNum As Double, cString As String
For sr = 2 To srCount ' skip headers
cString = CStr(Data(sr, SRC_COLUMN))
cPos = InStr(1, cString, CRIT_STRING_LEFT, vbTextCompare)
If cPos > 0 Then
cString = Right(cString, Len(cString) - cPos - cLen + 1)
cString = Replace(cString, "%", "")
cNum = Val(cString) ' 'Val' doesn't work with "!,#,#,$,%,&,^"
If cNum > CRIT_VALUE_GT Then ' 'Evaluate' is too slow!
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
End If
Next sr
Debug.Print "Modify Data: " & Format(Timer - T, "0.000s")
T = Timer
' Write Data: Write the values from the array to the destination range.
If dr = 0 Then Exit Sub ' no filtered values
' Reference the destination range.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim drg As Range: Set drg = dws.Range("A1").Resize(dr, cCount)
' Write to the range (practically this line uses up all the time).
drg.Value = Data
' Clear below
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
Debug.Print "Write Data: " & Format(Timer - T, "0.000s")
MsgBox "Data copied.", vbInformation
End Sub
The Result (Time Passed)
On a sample of 50k rows by 100 columns of data with 26k matches, the code finished in under 5s:
Read Data: 1.336s
Modify Data: 0.277s
Write Data: 3.375s
There were no blank cells and each cell in the criteria column contained the criteria string with a percentage hence it should be faster on your data. Your feedback is expected.
I am looking to count the occurrences of consecutive numbers in a column and cannot seem to find a logical way to calculate this within a loop.
My column of values is simply entries of 0 or 1. What I want to is count each time there is two 0's in a row, three 0's a row, four 0's in a row and so on. The maximum number of times I would expect a consecutive number is 15.
Ideally, I would like the output for each occurrence entered into a table.
I have provided a snapshot below of the column in question.
My attempts so far consist of looping through the column checking for two 0's in a row, starting at row 2 but this causes issues when I have more than two 0's in a row.
'Check for 2
Dim TwoCount, RowNo As Integer, LastRow As Long
LastRow = Sheets("Data").Range("A165536").End(xlUp).Row
TwoCount = 0
RowNo = 2
For i = 2 To LastRow
If Sheets("Data").Range("H" & RowNo).Value = 1 Then
RowNo = RowNo + 1
Else
If Sheets("Data").Range("H" & RowNo).Value = 0 Then
TwoCount = 1
RowNo = RowNo + 1
If Sheets("Data").Range("H" & RowNo).Value = 0 Then
TwoCount = 2
RowNo = RowNo + 1
If Sheets("Data").Range("H" & RowNo).Value = 1 Then
End If
End If
End If
End If
Next i
I welcome any suggestions to how I should approach this? Whether it's easier as a formula or array formula.
Desired output
Count Consecutive Occurrences
Option Explicit
Sub CountConsecutive()
' Source
Const sName As String = "Data"
Const sFirstCellAddress As String = "H1"
Const sCriteria As Variant = 0
' Destination
Const dName As String = "Data"
Const dFirstCellAddress As String = "J1"
Dim dHeaders As Variant
dHeaders = VBA.Array("Occurrences", "Number of Times")
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the source column to an array.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim Data As Variant
Dim rCount As Long
With sws.Range(sFirstCellAddress)
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then Exit Sub
rCount = slCell.Row - .Row + 1
If rCount < 2 Then Exit Sub
Data = .Resize(rCount).Value
End With
' Count the occurrences by using a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Long
Dim r As Long
Dim cCount As Long
Dim MaxCount As Long
For r = 2 To rCount
Key = Data(r, 1)
If IsNumeric(Key) Then
If Key = sCriteria Then
cCount = cCount + 1
Else
If cCount > 0 Then
dict(cCount) = dict(cCount) + 1
If cCount > MaxCount Then MaxCount = cCount
cCount = 0
End If
End If
End If
Next r
If MaxCount = 0 Then Exit Sub
' Write the values from the dictionary to the array.
rCount = MaxCount + 1
ReDim Data(1 To rCount, 1 To 2)
Data(1, 1) = dHeaders(0)
Data(1, 2) = dHeaders(1)
For r = 2 To rCount
Data(r, 1) = r - 1
If dict.Exists(r - 1) Then
Data(r, 2) = dict(r - 1)
Else
Data(r, 2) = 0
End If
Next r
' Write the values from the array to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, 2)
.Resize(rCount).Value = Data
.Resize(dws.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
'.Font.Bold = True
'.EntireColumn.AutoFit
End With
'wb.save
MsgBox "Consecutive count created.", vbInformation
End Sub
COUNTING THE FREQUENCY OF CONSECUTIVE OCCURRENCES OF 0 IN A COLUMN
You may try this array formula as well,
• Formula used in cell L2
=SUMPRODUCT(--(FREQUENCY(
IF($H$2:$H$32=0,ROW($H$2:$H$32)),
IF($H$2:$H$32=1,ROW($H$2:$H$32)))=K2))
And Fill Down!
Note: Array formulas need to be entered by pressing CTRL + SHIFT + ENTER (not just ENTER). Hold down both the CTRL key and the SHIFT key then hit ENTER. If you are using Excel 2021 or O365 you can only press ENTER.
Imagine your numbers Win/Lose in column A then add in cell B3 (not B2 this will stay empty) the following formula and copy it down:
=IF(AND(A3=0,A3<>A4),COUNTIF($A$2:A3,A3)-SUM($B$2:B2),"")
Then to count them just use =COUNTIF(B:B,E2) in F2 and copy it down.
You can read this requirements in two ways as I see it:
You can count an occurence of 1,2,3 and 4 in a sequence of 4 zero's;
You can count only the max occurence of the above;
I went with the assumptions of the latter:
Formula in C1:
=LET(X,SEQUENCE(15),Y,LEN(TEXTSPLIT(CONCAT(IF(A2:A32," ",1)),," ",1)),VSTACK({"Occurences of 0","Number of Times"},HSTACK(X,BYROW(X,LAMBDA(a,SUM(--(Y=a)))))))
Important note:
It may not be best to rely on CONCAT() since depending on the amount of rows you want to concatenate, it may strike a character limit. Instead you could try something like:
=LET(X,SEQUENCE(15),Y,LEN(TEXTSPLIT(REDUCE("",A2:A32,LAMBDA(a,b,a&IF(b," ",1))),," ",1)),VSTACK({"Occurences of 0","Number of Times"},HSTACK(X,BYROW(X,LAMBDA(a,SUM(--(Y=a)))))))
Also, please note that ms365 is required for the above functions to run properly (and at time of writing VSTACK(), HSTACK() and TEXTSPLIT() are still in the insider's BETA-channels.
I want to sort a column from smallest to largest. The column is like:
Day_Cluster
(0,5]
(10,15]
(5,10]
(15,20]
I want to sort from smallest to largest but it is not happening in MS Excel. How to achieve this?
Expected output:
(0,5]
(5,10]
(10,15]
(15,20]
A Special Sort
Manual
If your data is in column A, and you have data in column B then right-click in the column header of column B (selecting the whole column) and select Insert.
If your decimal separator is a period (dot) then use this formula in cell B1:
=VALUE(SUBSTITUTE(MID(A1,2,LEN(A1)-2),",","."))
and copy down as needed.
If your decimal separator is a comma then use this formula in cell B1:
=VALUE(MID(A1,2,LEN(A1)-2))
and copy down as needed.
Now sort your data by the B column ascending.
Delete column B or just clear the data in it.
Using VBA
Copy the code to a standard module, e.g. Module1.
The data is modified in place (no inserting, shifting...).
The decimal separator is irrelevant.
Option Explicit
Sub BubbleSortIntervalsASC()
Const ProcName As String = "BubbleSortIntervalsASC"
On Error GoTo ClearError
Const FirstCellAddress As String = "A1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the column range.
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, fCell.Column).End(xlUp).Row
Dim rCount As Long: rCount = lRow - fCell.Row + 1
If rCount < 2 Then Exit Sub
Dim srg As Range: Set srg = fCell.Resize(rCount)
' Write the values from the source (one-column) range to the source array.
Dim sData As Variant: sData = srg.Value
' Write the same values converted to numbers to the numbers array.
Dim nData As Variant: nData = ws.Evaluate("VALUE(SUBSTITUTE(MID(" _
& srg.Address & ",2,LEN(" & srg.Address & ")-2),"","","".""))")
Dim i As Long, j As Long
Dim sT As String, nT As Double
' Bubble sort the numbers array
' and do the same 'respective' shifting in the source array.
For i = 1 To rCount - 1
For j = i To rCount
If nData(i, 1) > nData(j, 1) Then
nT = nData(i, 1): nData(i, 1) = nData(j, 1): nData(j, 1) = nT
sT = sData(i, 1): sData(i, 1) = sData(j, 1): sData(j, 1) = sT
End If
Next j
Next i
' Write the sorted values from the source array to the source range.
srg.Value = sData
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
Im not sure exactly how to explain this in a google search so im not sure if anyone else has asked this.
I have a vba function that takes a range and turns it into a string of comma separated values.
It works like a charm.
Now i want it to only output the first 41 entries, switch down a row and output the next 41 entries in the range.
I cant quite wrap my head around it, it feels like a simple loop but i cant quite get there.
I found the csvrange macro online somewhere :)
Function csvRange(myRange As Range)
Dim csvRangeOutput
Dim entry As Variant
For Each entry In myRange
If Not IsEmpty(entry.Value) Then
csvRangeOutput = csvRangeOutput & entry.Value & ","
End If
Next
csvRange = Left(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
Input range would look like this
Desired output would look like this, one string located in column B each group of 41 values separated on a row, offsetting 1 down each time the function hits the next nr 42.
Something like this:
Option Explicit
Public Sub test()
Debug.Print csvRange(Selection, 41)
End Sub
Public Function csvRange(ByVal myRange As Range, ByVal Columns As Long) As String
Dim csvRangeOutput
Dim iCol As Long
Dim Entry As Variant
For Each Entry In myRange
If Not IsEmpty(Entry.Value) Then
iCol = iCol + 1
csvRangeOutput = csvRangeOutput & Entry.Value
If iCol = Columns Then
csvRangeOutput = csvRangeOutput & vbCrLf
iCol = 0
Else
csvRangeOutput = csvRangeOutput & ","
End If
End If
Next
csvRange = Left$(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
will turn this data
into comma separated values with 41 columns
1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41
42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82
83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123
124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140
Alternative
Public Sub Convert()
Const ColCount As Long = 41
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 1 To LastRow Step ColCount
ws.Cells(iRow \ ColCount + 1, "B").Value = "'" & Join((WorksheetFunction.Transpose(ws.Range("A" & iRow).Resize(RowSize:=IIf(iRow + ColCount - 1 > LastRow, WorksheetFunction.Max(LastRow Mod ColCount, 2), ColCount)).Value)), ",")
Next iRow
End Sub
Please, test the next code. It will do what (I understood) you need, for as many records you have in column A:A. It should be fast, using arrays and working in memory. The single iteration is for the necessary number of range slices:
Private Sub testStringCSVArray()
Dim sh As Worksheet, arr, nrSlices As Long, LastRow As Long, rngF As Range
Dim rngStart As Range, i As Long, k As Long, h As Long, arrFin
Set sh = ActiveSheet
LastRow = sh.Range("A1").End(xlDown).row
LastRow = sh.Range("A" & rows.count).End(xlUp).row 'last row of A:A
arr = sh.Range("A1:A" & LastRow).Value 'put the range in an array
nrSlices = UBound(arr) \ 41 'determine the number of necessary slices
ReDim arrFin(nrSlices + 1)
Set rngStart = sh.Range("B" & UBound(arr) + 2) 'set the cell where the result to be returned
For i = 1 To nrSlices + 1
arrFin(h) = CStr(Join(Application.Transpose(Application.Index(arr, _
Evaluate("row(" & k + 1 & ":" & IIf(i <= nrSlices, 41 + k, UBound(arr)) & ")"), 1)), ","))
k = k + 41: h = h + 1
Next i
'Format the range where the processed data will be returned and drop the processed data array:
With rngStart.Resize(h, 1)
.NumberFormat = "#"
.Value = WorksheetFunction.Transpose(arrFin)
End With
End Sub
In order to avoid deleting of the already processed data, in case of whishing to run the code twice or more times, the processed data will be returned in column B:B, two rows down from the last cell in column A:A. If after testing, the code proves to be reliable and no need to run it one more time, Set rngStart = sh.Range("B" & UBound(arr) + 2) can be modified in Set rngStart = sh.Range("A" & UBound(arr) + 2).
Without preliminary formatting as text the area where the data will be dropped, Excel changes the NumberFormat in "scientific", when the comma delimited string contains (only) numbers of three digits each. It looks to consider the comma as a thousands separator...
I have merged cells in my sheet "interspersed" and not in any pattern.
I need to replace the blank merged cells with "-"; dash.
Is there a faster way than this:
Sub ReplaceblankMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
If c.Value = "" Then
c.Value = "_"
End If
End If
Next
End Sub
I think you could break up the entire range to check in chunks, and check if each of these chunks contains merged cells. In the case of this being false, you won't have to check each cell in such a chunk, thereby saving time. How much time you would save, if any, would vary on your setup and the amount of chunks you specify.
Option Explicit
Sub ReplaceblankMergedCells()
Dim c As Range, r As Range
Dim startcolumn As Long, endcolumn As Long, startrow As Long, endrow As Long
Dim totalchunks As Integer, chunkcols As Integer, i As Integer
With Sheet2 'Edit
startcolumn = 1
endcolumn = 50
startrow = 2
endrow = 1000
totalchunks = 10 'set amount of chunks
chunkcols = Application.WorksheetFunction.RoundUp((endcolumn - startcolumn + 1) / totalchunks , 0) '10 chunks of 5 columns
For i = startcolumn To endcolumn Step chunkcols
Set r = .Range(.Cells(startrow, i), .Cells(endrow, i + chunkcols - 1))
'Prevent the loop from overshooting the last column
If i + chunkcols - 1 > endcolumn Then Set r = .Range(.Cells(startrow, i), .Cells(endrow, endcolumn))
'check if the chunk contains merged cells
If IsNull(r.MergeCells) = True Or r.MergeCells = True Then
'If it does contain merged cells, loop through the chunk
For Each c In r
If c.MergeCells And c.Value = "" Then c.Value = "_"
Next c
End If
Next i
End With
End Sub
As you can (hopefully) tell, I have divided the set range by ten. This breaks up the range in 10 equal parts of 5 rows, in case of the total amount of columns in the range being 50.
I advise you to play around with how large these chunks should be. You could also break up the chunks in more chunks horizontally, say half the rows in one sub-chunk and the other half in another sub-chunk.
Specify your worksheet or change the determination of the sheet and see if this does it for you ...
Public Sub ReplaceMergeCellsWithHyphen()
Dim objCells As Range, objCell As Range, objDict As New Scripting.Dictionary
Dim strRange As String, objSheet As Worksheet
Set objSheet = Worksheets("Sheet1")
Set objCells = objSheet.Range("A1:" & objSheet.Cells.SpecialCells(xlCellTypeLastCell).Address)
For Each objCell In objCells
If objCell.MergeArea.Cells.Count > 1 Then
If Not objDict.Exists(objCell.MergeArea.Address) Then objDict.Add objCell.MergeArea.Address, ""
End If
Next
With objSheet
For i = 0 To objDict.Count - 1
strRange = objDict.Keys(i)
If .Range(strRange).Cells(1, 1).Value = "" Then
.Range(strRange).Cells(1, 1).Value = "-"
End If
Next
End With
End Sub
It may be a bit hard to see in the image but after running the macro, the merged cells that do not have a value are filled with a hyphen.
Not sure if it's necessary faster but it works and (I think) is fairly robust.