Excel VBA
I will try my best to have this make sense.
I have set my array for 29 items (equipment ID T0001-T0028).
Essentially I have a report that has maintenance write-ups for these pieces of equipment. I am trying to create a loop that will go through the file and find each time the equid ID is listed and then i will use the left/right/mid functions to extract data from the file. However each equip ID will be listed multiple times so they way i am picturing this happening is for equip id T0001 the procedure will go through the entire file finding and extracting each time "T0001" is listed and then go to "T0002" and go through the entire file and so...
I know it will be a loop of some sort but I am so confused on whether to loop the file or loop the array. Can anyone help.
Sub EquipArray()
Dim sampleArr() As Variant
Dim i As Integer
Dim rng As Range, cell As Range
i = 1
Set rng = Range("A2:A29")
sampleArr = rng
End Sub
this is a loop that finds duplicates. alter to your needs
Private Sub this()
Dim rng As Range
Dim rCell As Range
Dim this As String
Dim arr(9)
Set rng = ThisWorkbook.Sheets("Sheet1").Range("a1:a10")
For Each rCell In rng.Cells
this = rCell.Value
For x = LBound(arr, 1) To UBound(arr, 1)
If this = arr(x) Then
rCell.Interior.ColorIndex = 7
Exit For
ElseIf this <> arr(x) And arr(x) = vbNullString Then
arr(x) = this
Exit For
End If
Next x
Next rCell
End Sub
If I understood it right, it will make no difference, since you'll have to loop it [number of files] * [number of items] (or [number of items] * [number of files], wich is the same).
Couldn't you use a formula to classify each file beforehand, so you don't have to test it against each item?
Related
This question already has an answer here:
Can we put dictionary items(array) into a Range with a single statement?
(1 answer)
Closed 6 months ago.
At the moment I have a range of names, and I need to create a new column which only contains the unique names.
Sub Unique_Values()
mySheet = Sheets("Sheet1").Range("E9:I20")
With CreateObject("scripting.dictionary")
For Each cell In mySheet
a = .Item(cell)
Next
Range("D2").Value = Join(.keys, vbLf)
End With
End Sub
This code creates a dictionary and returns the list of unique names, but it's one long list (i've just inserted it into D2) but I need it to populate column D with the unique names, one name per cell. I can't quite figure out how to loop through the keys and put them into an individual cell
Please, try the next updated code:
Sub Unique_Values()
Dim MySheet As Worksheet, rng As Range, cell As Range
Set MySheet = Sheets("Sheet1")
Set rng = MySheet.Range("E9:I20")
With CreateObject("scripting.dictionary")
For Each cell In rng.cells
.item(cell.Value) = 1
Next
MySheet.Range("D2").Resize(.count, 1).Value2 = Application.Transpose(.Keys)
End With
End Sub
It is good to declare all necessary variable, naming them in a relevant way.
Then, dict.keys is a 1D array (not having rows) and to place it in a column, it needs to be transposed.
I only tried adapting your code as it is. To make it faster, the iterated range should be placed in an array and then all the array processing will be done in memory, resulting a faster result. Anyhow, for the range you show us (if this is the real one), processing should take less than a second...
In fact, the faster version is easy to be designed, so here it is:
Sub Unique_Values_Array()
Dim MySheet As Worksheet, arr, i As Long, j As Long
Set MySheet = Sheets("Sheet1")
arr = MySheet.Range("E9:I20").Value2
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
.item(arr(i, j)) = 1
Next j
Next i
MySheet.Range("D2").Resize(.count, 1).Value2 = Application.Transpose(.Keys)
End With
End Sub
It makes sense and speed difference only in case of larger ranges...
If you use a collection you can create a unique list and write to the range. A collection will not let you add the same index key twice, therefore we ignore the error and then resume error checking when done writing.
Sub test()
Dim myNames As New Collection
Dim mySheet As Range
Dim i As Long
Set mySheet = Sheets("Sheet1").Range("E9:I20")
On Error Resume Next
For Each cell In mySheet
myNames.Add cell, cell.Value
Next
On Error GoTo 0
For i = 1 To myNames.Count
Worksheets("Sheet1").Cells(i + 2, 4) = myNames(i)
Next
End Sub
I have an array of ~5,000 unique IDs loaded from a CSV file:
Dim wb As Workbook
Dim idRng As Variant
Set wb = Workbooks.Open(Filename:=ThisWorkbook.path & "\DataSource\ID.csv")
With wb.Sheets(1)
idRng = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value2
End With
wb.Close
Alongside this, I also load in ~100,000 rows of data, which contains non-unique IDs with numerous possible duplicates. My aim is to loop through the 100,000 rows and check if the corresponding rows ID is contained within the smaller array, and if so, add the rows data to a collection. Both IDs are stored as Longs. I have completed this using the below:
Dim dataRng As Variant
Set wb = Workbooks.Open(Filename:=ThisWorkbook.path & "\DataSource\data.csv")
With wb.Sheets(1)
dataRng = .Range("A2:H" & .Range("A" & .Rows.Count).End(xlUp).Row).Value2
For i = LBound(dataRng) To UBound(dataRng)
If mUtil.IsInArray(dataRng(i, 1), idRng) Then
'Add object to collection
End If
Next
End With
'mUtil
Public Function IsInArray(v As Variant, arr As Variant) As Boolean
For i = LBound(arr) To UBound(arr)
If arr(i, 1) = v Then
IsInArray = True
Exit Function
End If
Next
IsInArray = False
End Function
Despite this working, as you can imagine iterating through the 5,000 unique IDs 100,000 times can take a fair amount of time, alongside this, the larger file can end up being much bigger.
Is there a more efficient way of performing this task, with the ultimate aim to reduce the run time?
I'd suggest throwing your 5,000 records into a dictionary and then use the Exists method to check to see if it does in fact exist.
Public Sub DictionaryTest()
Dim lngKey As Long, objDict As Object
Set objDict = CreateObject("Scripting.Dictionary")
lngKey = 123456
objDict.Add lngKey, 0
Debug.Print objDict.Exists(lngKey)
End Sub
It absolves you from having to loop over the 5,000 each time AND the power of the search within the dictionary should speed up the process 10 fold.
You can try something as simple as the following. Instead of looping twice, just loop one of them and Match if the item is found in the other array. I just tested with random numbers and just looped the unique values. This would work only if you want the first match. If you want all the matches you need to simply reverse it and loop the 100k non-unique array to the unique one.
What we do is create MatchArr as a Variant and then use that variable for our Application.Match function. If the function finds a match, it returns the row it found it on. If it doesn't find a match it will error, but because we made it a variant it won't stop the code. We simply check if it's an error or not and if it is then we simply move to the next line.
This is what I tried (Change as needed):
EDIT: I've updated to do the loop of the bigger array that needs to be refined.
Sub FindValues()
Dim Arr1, Arr2, MatchArr, i As Long, Col As New Collection
Arr1 = Sheet1.Range("A1:A50").Value
Arr2 = Sheet1.Range("C1:C1000").Value
For i = LBound(Arr2, 1) To UBound(Arr2, 1)
MatchArr = Application.Match(Arr2(i, 1), Arr1, 0)
If Not IsError(MatchArr) Then
Col.Add Arr2(i, 1)
End If
Next i
For i = 1 To Col.Count
Sheet1.Range("E" & i).Value = Col(i)
Next i
End Sub
Looking for a more appropriate approach. I have a working solution, but it seems there should be a built-in or more elegant method.
I am comparing two sheets from separate workbooks, documenting the differences on a sheet in current workbook. Every time a difference is found, I'm generating a row of output data. As I'm unaware of the total number of differences I will find, the row of output data is appended to an ArrayList.
I have a working bit of code, but the effective method is:
Create a row as an arraylist.
Convert the row to an array.
Add the row to an arraylist for output
TWICE Transpose the output arraylist while converting to an array
Output the array to worksheet.
With all the benefit of using ArrayLists, it seems that there should be a direct method for outputting a 2D "ArrayList of ArrayLists" or something along those lines.
Here is the current code:
Sub findUnmatchingCells()
Dim oWB_v1 As Workbook, oWB_v2 As Workbook, oRange_v1 As Range, oRange_v2 As Range
On Error GoTo endofsub
With Me
.Cells.Clear
.Cells(1, 1) = "Row"
.Cells(1, 2) = "Column"
.Cells(1, 3) = "v1"
.Cells(1, 4) = "v2"
End With
Dim missing_items As Object
Dim output_row(), output(), missing_row As Object
Set oWB_v1 = Workbooks("foo.xls")
Set oWB_v2 = Workbooks("bar.xls")
Set oRange_v1 = oWB_v1.Sheets(1).Range("A1:AD102")
Set oRange_v2 = oWB_v2.Sheets(1).Range("A1:AD102")
Set missing_items = CreateObject("System.Collections.ArrayList")
For rRow = 1 To oRange_v1.Rows.Count
For cCol = 1 To oRange_v1.Columns.Count
If oRange_v1.Cells(rRow, cCol) <> oRange_v2.Cells(rRow, cCol) Then
Set missing_row = CreateObject("System.Collections.ArrayList")
missing_row.Add rRow
missing_row.Add cCol
missing_row.Add oRange_v1.Cells(rRow, cCol).Value2
missing_row.Add oRange_v2.Cells(rRow, cCol).Value2
output_row = missing_row.toarray
missing_items.Add output_row
End If
Next cCol
Next rRow
output = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(missing_items.toarray))
'my own output routine
If Not outputArrayToRange(output, Me.Range("A2")) Then Stop
Exit Sub
endofsub:
Debug.Print rRow, cCol, missing_items.Count, missing_row.Count, Error
Stop
End Sub
Seems like a lot of extra work here with ArrayList when you are not really using anything useful from them. As you know the mismatch count cannot be more than the number of start elements, and the columns will be 4 at end, you can do all of this just with a single array. Pre-size the array and in your loop populate it.
Simplified example:
As you are using Me this code would be in "Sheet1".
Now it would get more complicated if you wanted to ReDim to actual number of mismatches to avoid over-writing something, but generally it is wise to plan developments to avoid such risks. You would need the double transpose to be able to ReDim the rows as columns then back to rows.
With the ranges you mention I don't think the Transpose limit would be an issue, but that is a concern in other cases which needs to be resolved with additional looping.
The efficient way is to use arrays the whole time. Read the two ranges into arrays, loop one and compare against the other, write out changes to pre-sized array, write array to sheet
If this is just about is there nicer functionality for this within ArrayLists, no. What you have done is short and effective but incurs more overhead than is necessary.
Option Explicit
Public Sub findUnmatchingCells()
Dim oWB As ThisWorkbook, oRange_v1 As Range, oRange_v2 As Range
With Me
.Cells.Clear
.Cells(1, 1) = "Row"
.Cells(1, 2) = "Column"
.Cells(1, 3) = "v1"
.Cells(1, 4) = "v2"
End With
Dim rRow As Long, cCol As Long
Set oWB = ThisWorkbook
Set oRange_v1 = oWB.Worksheets("Sheet2").Range("A1:D3") 'would be faster to read this into array and later loop that
Set oRange_v2 = oWB.Worksheets("Sheet3").Range("A1:D3") 'would be faster to read this into array and later loop that
Dim totalElements As Long, output()
totalElements = oRange_v1.Rows.Count * oRange_v1.Rows.Count
ReDim output(1 To totalElements, 1 To 4)
For rRow = 1 To oRange_v1.Rows.Count 'would be faster to loop arrays than sheet
For cCol = 1 To oRange_v1.Columns.Count
If oRange_v1.Cells(rRow, cCol) <> oRange_v2.Cells(rRow, cCol) Then
output(rRow, 1) = rRow
output(rRow, 2) = cCol
output(rRow, 3) = oRange_v1.Cells(rRow, cCol).Value2
output(rRow, 4) = oRange_v2.Cells(rRow, cCol).Value2
End If
Next cCol
Next rRow
oWB.Worksheets("Sheet1").Cells(2, 1).Resize(UBound(output, 1), UBound(output, 2)) = output
End Sub
Other thoughts:
You can have early bound if adding references is not a concern:
From: https://www.snb-vba.eu/VBA_Arraylist_en.html
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\Microsoft.NET\Framework\v4.0.30319\mscorlib.tlb"
or
ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
You are wasting an already created object by continually re-creating your missing_row ArrayList within loop. Create it once, before the loop, and just before you loop round again call the .Clear method.
I am using an IF statement in Excel to search for portions of text in the previous column in order to assign a supplier and category to the expense.
Supplier Column
=IF(ISNUMBER(SEARCH("tit",[#Description])),"TITAN",IF(ISNUMBER(SEARCH("Sol",[#Description])),"Soltrack",IF(ISNUMBER(SEARCH("coin",[#Description])),"Coin",IF(ISNUMBER(SEARCH("gree",[#Description])),"Green Dream Projects",IF(ISNUMBER(SEARCH("sars V",[#Description])),"SARS VAT",IF(ISNUMBER(SEARCH("sars p",[#Description])),"SARS PAYE",IF(ISNUMBER(SEARCH("acb",[#Description])),"Debit Order","")))))))
Category Column
the next column then has the following to get the category of the supplier
=IF(ISNUMBER(SEARCH("TITAN",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Soltrack",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Coin",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Green Dream Projects",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("SARS VAT",[#Payee])),"VAT",IF(ISNUMBER(SEARCH("SARS PAYE",[#Payee])),"PAYE",IF(ISNUMBER(SEARCH("Debit Order",[#Payee])),"Debit Order","")))))))
this is working great, but seems i have reached the limit (7) of IF statements I can use in one formula?
I have created the below function to search for text "tit" and if it matches it updates the Payee column.
'excel if range of cells contains specific text vba
Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Set Rng = Range("B2:B572") ' You can change this
specificText = "*tit*" ' You can change this
For Each Cell In Rng.Cells
If UCase(Cell.Value) Like "*" & UCase(specificText) & "*" Then
Cell.Offset(0, 1) = "Titan"
Else
Cell.Offset(0, 1) = ""
End If
Next
End Sub
Would I need to create a new specificText = "*tit*" for each of the keywords and also a whole section for each of the "For Each" functions?
Dictionary Solution
The first idea is to use a dictionary Replacements and add all the serach/replace pairs there. This has one huge disadvantage. It is against the good practice to not mix logic (code) and data. Good practice would be to put the data not into the code but into a worksheet (see next solution).
Option Explicit
Public Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements As Object
Set Replacements = CreateObject("Scripting.Dictionary")
With Replacements
.Add "tit", "Titan"
.Add "sol", "Soltrack"
'add more here
End With
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim Key As Variant
For Each Key In Replacements.Keys
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Key) & "*" Then
OutputValues(iRow, 1) = Replacements(Key)
Exit For 'we don't need to test for the others if we found a key
End If
Next Key
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
Worksheet Solution
The better solution would be to create a new worksheet Replacements as below:
This can easily be edited by anyone and you don't need to fiddle with the code later if you want to delete or add pairs.
Public Sub ImprovedCheckUsingWorksheet()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements() As Variant 'read replacements from worksheet
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "B").End(xlUp)).Value 'read input values into array
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim rRow As Long
For rRow = 1 To UBound(Replacements, 1)
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Replacements(rRow, 1)) & "*" Then
OutputValues(iRow, 1) = Replacements(rRow, 2)
Exit For 'we don't need to test for the others if we found a key
End If
Next rRow
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
For a 3ʳᵈ column in your replacements worksheet you would need to adjust the following line to be until column "C":
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "C").End(xlUp)).Value 'read input values into array
and the output values need another column too (second parameter needs to go 1 To 2):
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To UBound(Replacements, 2) - 1) 'this works for any amount of columns as it reads the column count from the `Replacements`
the data needs to be written
OutputValues(iRow, 1) = Replacements(rRow, 2) 'first output column
OutputValues(iRow, 2) = Replacements(rRow, 3) 'second output column
and writing the output values needs to be adjusted too:
RngToCheck.Offset(ColumnOffset:=1).Resize(ColumnSize:=UBound(OutputValues, 2)).Value = OutputValues 'this works for any amount of columns as it reads the column count from `OutputValues`
Formula Solution
But if you have your data in a worksheet Replacements like above, and you don't rely an a partial match. Then you don't need VBA and can easily use a formula instead to look it up:
=IFERROR(INDEX(Replacements!B:B,MATCH(B:B,Replacements!A:A,0)),"")
I'm trying to loop through several worksheets that contain some source data that has to be copied to one main sheet, called "PriorityList" here.
First of all, the sub is not working and I think the error is somewhere in the "find"-method. Second, the sub takes quite long to run, and I think this is maybe because the "find"-method searches through the whole sheet instead of only the relevant range?
Thank you very much for your answers!
Patrick
Sub PriorityCheck()
'Sub module to actualise the PriorityList
Dim CurrWS As Long, StartWS As Long, EndWS As Long, ScheduleWS As Long
StartWS = Sheets("H_HS").Index
EndWS = Sheets("E_2").Index
Dim SourceCell As Range, Destcell As Range
For CurrWS = StartWS To EndWS
For Each SourceCell In Worksheets(CurrWS).Range("G4:G73")
On Error Resume Next
'Use of the find method
Set Destcell = Worksheets(CurrWS).Cells.Find(What:=SourceCell.Value, After:=Worksheets("PriorityList").Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'Copying relevant data from source sheet to main sheet
If Destcell <> Nothing Then
Destcell.Offset(0, 2).Value = SourceCell.Offset(0, 5).Value + Destcell.Offset(0, 2).Value
If SourceCell.Offset(0, 3).Value = "x" Then Destcell.Offset(0, 3).Value = "x"
End If
End If
On Error GoTo 0
Next SourceCell
Next CurrWS
End Sub
here short sample how to use 'Find' method to find the first occurrence of the source.Value in the priorityList.
Source cell is one of the cells from the range "G4:G73" and priorityList is used range on "PriorityList" sheet. Hope this helps.
Public Sub PriorityCheck()
Dim source As Range
Dim priorityList As Range
Dim result As Range
Set priorityList = Worksheets("PriorityList").UsedRange
Dim i As Long
For i = Worksheets("H_HS").Index To Worksheets("E_2").Index
For Each source In Worksheets(i).Range("G4:G73")
Set result = priorityList.Find(What:=source.Value)
If (Not result Is Nothing) Then
' do stuff with result here ...
Debug.Print result.Worksheet.Name & ", " & result.Address
End If
Next source
Next i
End Sub
Here is an approach using arrays. You save each range into an array, then iterate through array to satisfy your if-else condition. BTW IF you want to find the exact line with code error, then you must comment On Error Resume Next line.. :) Further, you can simply store the values into a new array, dump everything else into the main sheet later after iterating through all the sheets instead of going back and forth to sheets, code, sheets..code..
Dim sourceArray as Variant, priorityArray as Variant
'-- specify the correct priority List range here
'-- if multi-column then use following method
priorityArray = Worksheets(CurrWS).Range("A1:B10").Value
'-- if single column use this method
' priorityArray = WorkSheetFunction.Transpose(Worksheets(CurrWS).Range("A1:A10").Value)
For CurrWS = StartWS To EndWS
On Error Resume Next
sourceArray = Worksheets(CurrWS).Range("G4:J73").Value
For i = Lbound(sourceArray,1) to UBound(sourceArray,1)
For j = Lbound(priorityArray,1) to UBound(priorityArray,1)
If Not IsEmpty(vArr(i,1)) Then '-- use first column
'-- do your validations here..
'-- offset(0,3) refers to J column from G column, that means
'---- sourceArray(i,3)...
'-- you can either choose to update priority List sheet here or
'---- you may copy data into a new array which is same size as priorityArray
'------ as you deem..
End If
Next j
Next i
Next CurrWS
PS: Not front of a MS Excel installed machine to try this out. So treat above as a code un-tested. For the same reason I couldn't run your find method. But it seems odd. Don't forget when using match or find it's important to do proper error handling. Try checking out [find based solutions provided here.
VBA in find function runtime error 91
Excel 2007 VBA find function. Trying to find data between two sheets and put it in a third sheet
I have edited the initial code to include the main logic using two array. Since you need to refer to values in J column of source sheets, you will need to adjust source array into a two-dimensional array. So you can do the validations using first column and then retrieve data as you desire.
For everyone maybe interested, this is the code version that I finally used (pretty similar to the version suggested by Daniel Dusek):
Sub PriorityCheck()
Dim Source As Range
Dim PriorityList As Range
Dim Dest As Range
Set PriorityList = Worksheets("PriorityList").UsedRange
Dim i As Long
For i = Worksheets("H_HS").Index To Worksheets("S_14").Index
For Each Source In Worksheets(i).Range("G4:G73")
If Source <> "" Then
Set Dest = PriorityList.Find(What:=Source.Value)
If Not Dest Is Nothing Then
If Dest <> "" Then
Dest.Offset(0, 2).ClearContents
Dest.Offset(0, 2).Value = Source.Offset(0, 5).Value + Dest.Offset(0, 2).Value
End If
If Source.Offset(0, 3).Value = "x" Then Dest.Offset(0, 3).Value = "x"
Debug.Print Dest.Worksheet.Name & ", " & Dest.Address
End If
End If
Next Source
Next i
MsgBox "Update Priority List completed!"
End Sub