Search multiple strings in a excel workbook - arrays

I am trying to design a macro to search for multiple strings in an excel.
I have the following code which searches for the word "techno" in an excel but, I need to include a variable into the code so that I can search for multiple words such "Techno", "electromagnetic", "waves", etc. at once. I am unable to create a loop for this condition.
Can anyone suggest a solution to this problem? The below code works fine but, only a tweak is required to include multiple strings in the search.
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("techno", "magnetic", "laser", "trent")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & " is the Count No."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & " is the Value fr String search"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
MsgBox xFound & " is the strings found"
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
MsgBox xCount & " is the count of strings"
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
MsgBox xFound & " next string"
MsgBox xStrAddress & " is the address "
MsgBox xFound.Address & " is the address found"
Loop While xStrAddress <> xFound.Address 'To check how xStrAddress is populated or do we need to declare it as a help from excel pointed out
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
Next myCounter
MsgBox xCount & "cells have been found", ,
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

If the strings you are searching will always be the same, hard code them into an array and Loop through the array elements to search each string, like so:
Dim myArray as Variant
Dim myCounter as Long
myArray = Array("techno", "electromagnetic", ...etc.)
For myCounter = 0 To UBound(myArray)
... 'your code here
xStrSearch = myArray(myCounter)
... 'the rest if your code here
Next myCounter

Related

Fetching email addresses with email domain cell value

I fetch email addresses from my Outlook account.
Now I am trying to fetch only specific email address from inbox e.g. Gmail.com that returns gmail addresses only.
I modified the code where I used array to store the addresses temporarily and then compare to string. After altering the code it returns nothing (not even errors).
Option Explicit
Sub GetInboxItems()
Dim ol As outlook.Application
Dim ns As outlook.Namespace
Dim fol As outlook.Folder
Dim I As Object
Dim mi As outlook.MailItem
Dim N As Long
Dim val As String
Dim MyArray() As String, MyString As String, J As Variant, K As Integer
Dim MyAs As Variant
Dim Awo As Variant
MyString = Worksheets("Inbox").Range("D1")
MyArray = Split(MyString, ";")
Application.ScreenUpdating = False
Set ol = New outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
'Dim inputSheet As Worksheet
'Dim aCellOnInputSheet As Range
'Dim inputDateCell As Range
'Dim userSheetName As String
'Set cod = ThisWorkbook.Worksheets("Inbox")
'Set aCellOnInputSheet = cod.Range("D1")
'userSheetName = aCellOnInputSheet.Value
Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
N = 2
For Each I In fol.Items
If I.Class = olMail Then
Set mi = I
N = N + 1
If mi.SenderEmailType = "EX" Then
MyAs = Array(mi.Sender.GetExchangeUser().PrimarySmtpAddress)
For Each Awo In MyAs
If InStr(MyString, Awo) > 0 Then
Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
Cells(N, 2).Value = mi.SenderName
Exit For
End If
Next
' Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
' Cells(N, 2).Value = mi.SenderName
Else
MyAs = Array(mi.SenderEmailAddress)
For Each Awo In MyAs
If InStr(MyString, Awo) > 0 Then
Cells(N, 1).Value = mi.SenderEmailAddress
Cells(N, 2).Value = mi.SenderName
Exit For
End If
Next
End If
End If
Next I
Application.ScreenUpdating = True
End Sub
Fetching all email addresses will be problematic. I don't want to expose any email domains other than the defined ones.
Minimal changes to manipulating the row n and switching the variables in Instr should be sufficient.
This also shows how to drop the array if one domain.
Option Explicit
Sub GetInboxItems_SingleDomain()
' Early binding - reference to Microsoft Outlook XX.X Object Library required
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim folItm As Object
Dim mi As Outlook.MailItem
Dim n As Long
Dim myString As String
Dim myAddress As String
myString = Worksheets("Inbox").Range("D1") ' gmail.com
'Debug.Print myString
Application.ScreenUpdating = False
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
n = 3
' If slow, limit the number of items in the loop
' e.g. https://stackoverflow.com/questions/21549938/vba-search-in-outlook
' strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & myString & "'"
For Each folItm In fol.Items
If folItm.Class = olMail Then
Set mi = folItm
If mi.SenderEmailType = "EX" Then
myAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
Else
myAddress = mi.SenderEmailAddress
End If
'Debug.Print myAddress
'The bigger text on the left
' In general, not necessarily here, keep in mind case sensitivity
If InStr(LCase(myAddress), LCase(myString)) > 0 Then
Cells(n, 1).Value = myAddress
Cells(n, 2).Value = mi.SenderName
n = n + 1
End If
End If
Next folItm
Application.ScreenUpdating = True
Debug.Print "Done."
End Sub

Remove delimiters from Join() Function in EXcel VBA

I am a novice programmer and I'm building a form via VBA for excel where the user will input employee's time sheet and their initials via 16 text box's in the form. The text boxes data are stored to a string array. The code is:
Dim initials(15) As String
initials(0) = TB_Initials_1
initials(1) = TB_Initials_2
initials(2) = TB_Initials_3
...
initials(15) = TB_Initials_15
After using the find function and referencing some data from a one excel sheet, I use
ActiveCell.Offset(0, 2).Value = Join(initials, ".")
to output the following
"js.rs.............." to the active cell in a different excel sheet, (I only entered 2 of the 16 input boxes, hence there's two initials. JS.RS
The trailing .............. is what I want to remove. this will be imported into a Database later via the excel sheet.
How can I remove the xtras ".........'s at the end of the string? I have tried the "Trim()" function, but that does not work in my case. Everything i've tried online does not seem to work either or is referencing items from a work book, not a text box.
Any help is appreciated.
The entire code is below:
Option Explicit
'Variable declaration
Dim startTime(15), endTime(15), ST_Finish_Date As Date
Dim totalmin(15), Total_min, Total_Cost, Rate(15), Line_cost(15), Cost_Per_Part As String
Dim initials(15) As String
Dim i, ii As Integer
Dim Found_ini(15) As Range
Dim Found As Range 'returned value from find
Dim TBtraveller_value As String 'text box traveller value
Dim Found2 As Range 'store part code range
Dim TBDESC As Range ' Returned value from 2nd search
Dim BL_Find_Check As Boolean
Private Sub CB_Write_Click()
create_csv
End Sub
Private Sub Close_Form_Click()
Unload Traveller_Entry
End Sub
'still need to make this for every start / stop time text box.
Private Sub TB_Time_Start_1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim myvar As String
If Not Me.TB_Time_Start_1 Like "??:??" Then
MsgBox "Please use format 'HH:MM'"
Cancel = True
Exit Sub
End If
myvar = Format(Me.TB_Time_Start_1, "hh:mm")
Me.TB_Time_Start_1 = myvar
End Sub
Public Sub travellerNUM_TextBox_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Workbooks("Traveller entryxlsm.xlsm").Activate
TBtraveller_value = travellerNUM_TextBox.Value
If TBtraveller_value = "" Then
MsgBox ("Enter a Shop Traveller Number!")
Exit Sub
Else
TBtraveller_value = travellerNUM_TextBox.Value
Set Found = Sheets("woss").Range("A:A").Find(what:=TBtraveller_value, lookat:=xlWhole)
If Found Is Nothing Then
MsgBox (TBtraveller_value & " Not Found!")
Exit Sub
Else
Part_Code_BOX.Value = Found.Offset(0, 1) 'enters the info into the Part Code Box.
Set Found2 = Found.Offset(0, 1)
End If
If Part_Code_BOX = "" Then
MsgBox ("Traveller number " & TBtraveller_value & " has no part code associated with it." & vbCrLf & "Check Work Order Spread Sheet is FULLY Complete.")
BL_Find_Check = True
Exit Sub
End If
Set TBDESC = Sheets("ProductList").Range("B:B").Find(what:=Found2, lookat:=xlPart)
If TBDESC Is Nothing Then
MsgBox (" Dscription Not Found!")
Else
Desc_Box = TBDESC.Offset(0, 1) 'enters the description into the description Box.
FinishDate_Box = Found.Offset(0, 8) 'enters the finish date into the finish date Box.
Employee = Found.Offset(0, 2) 'enters the Employee name into the employee name Box.
End If
End If
End Sub
Public Sub CB_POST_Click()
On Error Resume Next
startTime(0) = TB_Time_Start_1.Value
startTime(1) = TB_Time_Start_2.Value
startTime(2) = TB_Time_Start_3.Value
startTime(3) = TB_Time_Start_4.Value
startTime(4) = TB_Time_Start_5.Value
startTime(5) = TB_Time_Start_6.Value
startTime(6) = TB_Time_Start_7.Value
startTime(7) = TB_Time_Start_8.Value
startTime(8) = TB_Time_Start_9.Value
startTime(9) = TB_Time_Start_10.Value
startTime(10) = TB_Time_Start_11.Value
startTime(11) = TB_Time_Start_12.Value
startTime(12) = TB_Time_Start_13.Value
startTime(13) = TB_Time_Start_14.Value
startTime(14) = TB_Time_Start_15.Value
startTime(15) = TB_Time_Start_16.Value
endTime(0) = TB_Time_Stop_1.Value
endTime(1) = TB_Time_Stop_2.Value
endTime(2) = TB_Time_Stop_3.Value
endTime(3) = TB_Time_Stop_4.Value
endTime(4) = TB_Time_Stop_5.Value
endTime(5) = TB_Time_Stop_6.Value
endTime(6) = TB_Time_Stop_7.Value
endTime(7) = TB_Time_Stop_8.Value
endTime(8) = TB_Time_Stop_9.Value
endTime(9) = TB_Time_Stop_10.Value
endTime(10) = TB_Time_Stop_11.Value
endTime(11) = TB_Time_Stop_12.Value
endTime(12) = TB_Time_Stop_13.Value
endTime(13) = TB_Time_Stop_14.Value
endTime(14) = TB_Time_Stop_15.Value
endTime(15) = TB_Time_Stop_16.Value
initials(0) = TB_Initials_1
initials(1) = TB_Initials_2
initials(2) = TB_Initials_3
initials(3) = TB_Initials_4
initials(4) = TB_Initials_5
initials(5) = TB_Initials_6
initials(6) = TB_Initials_7
initials(7) = TB_Initials_8
initials(8) = TB_Initials_9
initials(9) = TB_Initials_10
initials(10) = TB_Initials_11
initials(11) = TB_Initials_12
initials(12) = TB_Initials_13
initials(13) = TB_Initials_14
initials(14) = TB_Initials_15
initials(15) = TB_Initials_16
For i = LBound(initials) To UBound(initials)
Set Found_ini(i) = Sheets("rate").Range("B:B").Find(what:=initials(i), lookat:=xlWhole)
Rate(i) = Found_ini(i).Offset(0, 1) 'finds rate for given initials
totalmin(i) = DateDiff("N", startTime(i), endTime(i))
If Found_ini(i) Is Nothing Then
MsgBox (initials(i) & " Not Found! Update Employee Database.")
Exit Sub
'If IsEmpty(Found_ini(i)) = False And IsEmpty(startTime(i)) = True And IsEmpty(endTime(i)) = True Then
'MsgBox "Enter Some Initials, None Found"
Exit Sub
End If
Next
For ii = LBound(totalmin) To UBound(totalmin)
Line_cost(ii) = totalmin(ii) / 60 * Rate(ii)
Next
Total_min = Application.WorksheetFunction.Sum(totalmin)
Total_Cost = Application.WorksheetFunction.Sum(Line_cost)
Cost_Per_Part = Total_Cost / TextBOX_QTYBUILT
If Total_min = 0 Then
MsgBox (" Enter Some Time!")
ElseIf Total_min < 0 Then
MsgBox ("Time is NEGATIVE. Check Entered Times.")
End If
If BL_Find_Check = False Then
MsgBox "The number of minutes between two Times : " & Total_min & vbNewLine & "total cost: " & Total_Cost _
& vbNewLine & "cost Per Part " & Cost_Per_Part, vbInformation, "Minutes Between Two Times"
Sheets("test").Select
Range("A1048576").Select
ActiveCell.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 0).Value = FinishDate_Box 'Traveller finish Date
ActiveCell.Offset(0, 1).Value = TBtraveller_value 'Traveller Number
ActiveCell.Offset(0, 2).Value = Join(initials, ".") 'Traveller Employee Given to
ActiveCell.Offset(0, 3).Value = Part_Code_BOX.Value ' part number
ActiveCell.Offset(0, 4).Value = Total_Cost ' traveller total cost
ActiveCell.Offset(0, 5).Value = Cost_Per_Part 'Traveller cost per part
End If
End Sub
Sub create_csv()
Dim FileName As String
Dim PathName As String
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("test")
FileName = "CSV_Output_R1.csv"
PathName = Application.ActiveWorkbook.Path
ws.Copy
ActiveWorkbook.SaveAs FileName:=PathName & "\" & FileName, _
FileFormat:=xlCSV, CreateBackup:=False
End Sub
Thank you,
You can use WorksheetFunction.TextJoin() in Excel2019+ in one string:
ActiveCell.Offset(0, 2).Value = WorksheetFunction.TextJoin(".", True, initials)
A small example for comparison:
Sub test1()
Dim arr(1 To 15)
For i = 1 To 15
arr(i) = IIf(Rnd() > 0.7, "TXT", "")
Next
Debug.Print "With Join(): " & Join(arr, ".")
Debug.Print "With TextJoin(): " & WorksheetFunction.TextJoin(".", True, arr)
End Sub
Output
With Join(): ..TXT........TXT..TXT..
With TextJoin(): TXT.TXT.TXT
Here is a function that I just made to trim empty elements off the end of your array:
Function TrimArray(ByRef StringArray() As String) As String()
'This function removes trailing empty elements from arrays
'Searching from the last element backwards until a non-blank is found
Dim i As Long
For i = UBound(StringArray) To LBound(StringArray) Step -1
If StringArray(i) <> "" Then Exit For
Next i
If i < LBound(StringArray) Then i = LBound(StringArray)
'Creating an array with the correct size to hold the non-blank elements
Dim OutArr() As String
OutArr = StringArray
ReDim Preserve OutArr(LBound(StringArray) To i)
TrimArray = OutArr
End Function
You would use it like so:
Dim Output() As String
Output = TrimArray(initials)
MsgBox Join(Output, ".") & "."
You could build it like this instead of using Join():
ActiveCell.Offset(0, 2).Value = initials(0)
For Counter = 1 To 15
If initials(Counter) <> "" Then
ActiveCell.Offset(0, 2).Value = ActiveCell.Offset(0, 2).Value + "." + initials(Counter)
End If
Next Counter

Convert subroutine to a function that can be used in a formula

I'm not very good with functions and was hoping someone could help convert this. I will be inserting the formula with a macro.
I have tried using formulas but run into issues when 2 or more matches are found.
The function will be inserted via macro like so.:
ws1.Range(Cells(x, spec), Cells(lRow, spec)).Formula = "=IFERROR(IF(OR(MID(RC[-3],SEARCH(""-"",RC[-3])+1,SEARCH(""-"",RC[-3],SEARCH(""-"",RC[-3])+1)-SEARCH(""-"",RC[-3])-1) = ""WP"",MID(RC[-3],SEARCH(""-"",RC[-3])+1,SEARCH(""-"",RC[-3],SEARCH(""-"",RC[-3])+1)-SEARCH(""-"",RC[-3])-1)=""DO""),""A15"",MID(RC[-3], FIND(CHAR(1),SUBSTITUTE(RC[-3],""-"",CHAR(1)," & aft & "))+1, FIND(CHAR(1),SUBSTITUTE(RC[-3],""-"",CHAR(1)," & aft + 1 & ")) - FIND(CHAR" & _
"(1),SUBSTITUTE(RC[-3],""-"",CHAR(1)," & aft & "))-1)),"""")" & ""
Sub Test()
Dim ws1, ws2 As Worksheet
Dim SrchRng As Range, cel As Range
Dim SrchStr As String
Dim myList, tbl As Object
Dim arr As Variant
Dim i, x As Integer
Dim val as String
Set ws1 = ThisWorkbook.Sheets("Index")
Set ws2 = ThisWorkbook.Sheets("Data Entry")
Set SrchRng = ws1.Range("A2:A30")
Set myList = CreateObject("System.Collections.ArrayList")
SrchStr = ws2.Range("AB7")
For Each cel In SrchRng
If InStr(1, SrchStr, cel.Value, vbTextCompare) > 0 Then
myList.Add cel.Value
arr = myList.Toarray
End If
Next cel
'######### Need to compare string length and keep the highest value ##########
For i = LBound(arr) To UBound(arr)
If IsNull(x) Or Len(arr(i)) > x Then
x = Len(arr(i))
val = arr(i)
End If
Next i
ws2.Range("AE7") = val
Debug.Print x
Debug.Print a
Set ws1 = Nothing
Set ws2 = Nothing
Set SrchRng = Nothing
Set myList = Nothing
End Sub
EDITED due to updated question.
A double loop will conduct a one to one search against the data to ensure that any duplicate entries are caught and correctly labelled.
Assuming there is some consistency with the formatting, this will look for the search criteria and - (ie: "A12UG-"). This will eliminate "A12UG" from triggering with "A12".
To call the function, assign the call to a variable. ie: varName = updateAE()
Function updateAE()
Dim ws1: Set ws1 = ThisWorkbook.Sheets("Index")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Data Entry")
Dim srchRng As Range, indexRng As Range, indexCel As Range, srchCel As Range
Dim i As Integer
Dim count As Integer
Dim indexLRow, srchLRow As Long
indexLRow = ws1.Cells(ws2.Rows.count, "A").End(xlUp).Row
srchLRow = ws2.Cells(ws2.Rows.count, "AB").End(xlUp).Row
Set indexRng = ws1.Range("A1:A" & indexLRow)
Set srchRng = ws2.Range("AB3:AB" & srchLRow)
count = 1
On Error Resume Next
For Each indexCel In indexRng
For Each srchCel In srchRng
If InStr(1, srchCel, indexCel & "-") > 0 And Len(indexCel) > 0 Then
ws2.Range("AE" & count + 2) = indexCel
End If
count = count + 1
Next srchCel
count = 1
Next indexCel
End Function
Output:

Storing cell addresses into an array in vba while using a loop

I am trying to work through a code that utilizes a system to check two different worksheets by using a for loop and highlight the differences/edits made in the second sheet ("Version 2") onto the first sheet ("Original"). I have a feeling that I need to utilize an array but I'm not advanced enough where I know how to store the values and then later write them onto another sheet (down below).
I've gotten the code so that it highlights all the relevant cells, but now I'm trying to output it into a report (on another sheet called 'Logged Changes') which will summarize all the cell addresses where edits were made. Please forgive all the variables as this is from an old code set where variables are not explicitly defined:
Private Sub CompareBasic()
Dim actSheet As Range
Dim k As Integer
Dim o As Long
Dim p As Long
Dim i As Integer
Dim change As Integer
o = Worksheets("Original").Cells(2, Columns.Count).End(xlToLeft).Column
p = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
change = 0
Sheets("Original").Select
For i = 2 To p
For k = 1 To o
If IsNumeric(Worksheets("Original").Cells(i, k).Value) = True Then
If Worksheets("Original").Cells(i, k).Value <> Worksheets("Version 2").Cells(i, k).Value Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
Else
If StrComp(Worksheets("Original").Cells(i, k), Worksheets("Version 2").Cells(i, k), vbBinaryCompare) <> 0 Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
End If
Next k
Next i
Unload Me
MsgBox "Number of cells edited counted: " & change, vbOKOnly + vbExclamation, "Summary"
b = Empty
answer = MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion)
If answer = vbYes Then
If Sheet_Exists("Logged Changes") = False Then
Sheet_Name = "Logged Changes"
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
End If
Worksheets("Logged Changes").Range("A1") = "Edited Requirements"
Else
Unload Me
End If
End Sub
I have tried fiddling around with the code, but didn't want to clog it up with any unnecessary/broken lines. Any help would be greatly appreciated!
Try this:
Option Explicit
Private Sub CompareBasic()
Const SHT_REPORT As String = "Logged Changes"
Dim actSheet As Range
Dim c As Integer
Dim o As Long
Dim p As Long
Dim r As Long
Dim change As Long, wsOrig As Worksheet, wsNew As Worksheet, wsReport As Worksheet
Dim dataOrig, dataNew, rngData As Range, v1, v2, bDiff As Boolean
Dim arrUpdates
Set wsOrig = Worksheets("Original")
Set wsNew = Worksheets("Version 2")
o = wsOrig.Cells(2, Columns.Count).End(xlToLeft).Column
p = wsOrig.Range("A" & Rows.Count).End(xlUp).Row
Set rngData = wsOrig.Range("A2", wsOrig.Cells(p, o))
dataOrig = rngData.Value 'get an array of data
dataNew = wsNew.Range(rngData.Address).Value 'array of new data
ReDim arrUpdates(1 To rngData.Cells.Count, 1 To 3) 'for change info
change = 0
For r = 1 To UBound(dataOrig, 1)
For c = 1 To UBound(dataOrig, 2)
v1 = dataOrig(r, c)
v2 = dataNew(r, c)
If Len(v1) > 0 Or Len(v2) > 0 Then
If IsNumeric(v1) Then
bDiff = v1 <> v2
Else
bDiff = StrComp(v1, v2, vbBinaryCompare) <> 0
End If
End If
'any difference?
If bDiff Then
change = change + 1
With rngData.Cells(r, c)
arrUpdates(change, 1) = .Address
.Interior.ColorIndex = 37
End With
arrUpdates(change, 2) = v1
arrUpdates(change, 3) = v2
End If
Next c
Next r
If MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion) = vbYes Then
With GetSheet(SHT_REPORT, ThisWorkbook)
.UsedRange.ClearContents
.Range("A1") = "Edited Requirements"
.Range("A3").Resize(1, 3).Value = Array("Address", wsOrig.Name, wsNew.Name)
.Range("A4").Resize(change, 3).Value = arrUpdates
End With
Else
'Unload Me
End If
End Sub
'return as sheet from wb by name (and create it if it doesn't exist)
Function GetSheet(wsName, wb As Workbook) As Worksheet
Dim rv As Worksheet
On Error Resume Next
Set rv = wb.Worksheets(wsName)
On Error GoTo 0
If rv Is Nothing Then
Set rv = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
rv.Name = "Logged Changes"
End If
Set GetSheet = rv
End Function
Sheet Differences
Option Explicit
Sub logChanges()
Const ws1Name As String = "Original"
Const ws2Name As String = "Version 2"
Const wsResult As String = "Logged Changes"
Const FirstRow As Long = 2
Const FirstColumn As Long = 1
Const LastRowColumn As Long = 1
Const LastColumnRow As Long = 2
Const ResultFirstCell As String = "A2"
Dim Headers As Variant
Headers = Array("Id", "Address", "Original", "Version 2")
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(ws1Name)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
Dim LastColumn As Long
LastColumn = ws.Cells(LastColumnRow, ws.Columns.Count) _
.End(xlToLeft).Column
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, FirstColumn), _
ws.Cells(LastRow, LastColumn))
Dim Data1 As Variant: Data1 = rng.Value
Set ws = wb.Worksheets(ws2Name)
Dim Data2 As Variant: Data2 = ws.Range(rng.Address).Value
Dim Result() As Variant
Dim i As Long, j As Long, k As Long
For i = 1 To UBound(Data1)
For j = 1 To UBound(Data1, 2)
If Data1(i, j) <> Data2(i, j) Then GoSub writeResult
Next j
Next i
If k > 0 Then
transpose2D Result
On Error GoTo MissingResultSheet
Set ws = wb.Worksheets(wsResult)
On Error GoTo 0
ws.Range(ws.Range(ResultFirstCell), _
ws.Cells(ws.Rows.Count, ws.Columns.Count)).Clear
ws.Range(ResultFirstCell).Resize(k, UBound(Result, 2)).Value = Result
MsgBox "Found '" & k & "' difference(s) in range '" _
& rng.Address(False, False) & "'.", vbInformation
Else
MsgBox "Found no differences in range '" _
& rng.Address(False, False) & "'.", vbExclamation
End If
Exit Sub
writeResult:
k = k + 1
ReDim Preserve Result(1 To 4, 1 To k)
Result(1, k) = k
Result(2, k) = getAddress(i + FirstRow - 1, j + FirstColumn - 1)
Result(3, k) = Data1(i, j)
Result(4, k) = Data2(i, j)
Return
MissingResultSheet:
If Err.Number = 9 Then
wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
With ActiveSheet
.Name = wsResult
If .Range(ResultFirstCell).Row > 1 Then
.Range(ResultFirstCell).Offset(-1) _
.Resize(, UBound(Headers) + 1).Value = Headers
End If
End With
Resume ' i.e. the code continues with Set ws = wb.Worksheets(wsResult)
Else
'?
Exit Sub
End If
End Sub
Function getAddress(aRow As Long, aColumn As Long) As String
getAddress = ActiveSheet.Cells(aRow, aColumn).Address(False, False)
End Function
Sub transpose2D(ByRef Data As Variant)
Dim i As Long, j As Long
Dim Result As Variant
ReDim Result(LBound(Data, 2) To UBound(Data, 2), _
LBound(Data) To UBound(Data))
For i = LBound(Data) To UBound(Data)
For j = LBound(Data, 2) To UBound(Data, 2)
Result(j, i) = Data(i, j)
Next j
Next i
Data = Result
End Sub
This solution for converting a column number to a string without using objects Function to convert column number to letter? could be used to write a descent getAddress function.

remove duplicates from an array - vba

I have a code, that grabs data from a column of a file, and puts it into an array.
now, I want to go through this array and delete duplicates but I can't make it go through... any ideas?
this is the code, and the array is at the end:
Dim i As Long
Dim searchItem As Variant
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
Next i
End With
s_wbk.Close
searchItem = Split(strSearch, ",") '*NEED TO REMOVE DUPLICATES
Remove the duplicates during the string construction by testing for prior existence with InStr function.
If Not IsEmpty(Cells(i, 1).Value) And _
Not InStr(1, strSearch, Cells(i, 1).Value & ",", vbTextCompare) Then
strSearch = strSearch & "," & Cells(i, 1).Value
End If
You should also remove the last trailing comma before splitting.
Next i
strSearch = Left(strSearch, Len(strSearch) - 1)
Finally, if you had added the values into a Scripting.Dictionary object (which comes with its own unique primary key index), you would have a unique set of keys in an array already built for you.
This worked for me:
Function removeDuplicates(ByVal myArray As Variant) As Variant
Dim d As Object
Dim v As Variant 'Value for function
Dim outputArray() As Variant
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
For i = LBound(myArray) To UBound(myArray)
d(myArray(i)) = 1
Next i
i = 0
For Each v In d.Keys()
ReDim Preserve outputArray(0 To i)
outputArray(i) = v
i = i + 1
Next v
removeDuplicates = outputArray
End Function
Hope it helps
Easiest way would be to duplicate the sheet you take your input from and use built-in function to get rid of the duplicates, take a look at this :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
For i = 1 To .Range("A" & .Rows.count).End(xlUp).Row
If Not IsEmpty(.Cells(i, 1)) Then
strSearch = strSearch & "," & .Cells(i, 1).Value
End If
Next i
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
searchItem = Split(strSearch, ",") 'NO MORE DUPLICATES ;)
Or even faster (as you won't have empty cells in the range after the RemoveDuplicates) :
Dim i As Long
Dim searchItem As Variant
Dim Ws As Worksheet
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
'Copy the sheet
s_wbk.Sheets("Sheet1").Copy (s_wbk.Sheets(1))
Set Ws = s_wbk.Sheets(1)
With Ws
'Remove duplicates from column A
With .Range("A:A")
.Value = .Value
.RemoveDuplicates _
Columns:=Array(1), _
Header:=xlNo
End With
'NO MORE DUPLICATES and FASTER ARRAY FILL ;)
searchItem = .Range(.Range("A1"), .Range("A" & .Rows.count).End(xlUp)).Value
'Get rid of that new sheet
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = False
End With
s_wbk.Close
Usually I use a dictionary object to check for duplicates, or use it itself. A dictionary is an object that references unique keys to values. Since the keys have to be unique it is quite usable for collecting unique values. Maybe it is not the most memory efficient way and probaby a little abues of the object, but it works quite fine.
You have to dim an object and set it to a dictionary, collect the data, after checking it doesn't already exist and then loop through the dictionary to collect the values.
Dim i As Long
Dim searchItem As Variant, var as variant
dim dicUniques as object
set dicUniques = CreateObject("Scripting.Dictionary")
strSearch = ""
searchItem = ""
strFile = "...\Desktop\xl files min\src.xlsm"
Set s_wbk = Workbooks.Open(strFile)
With s_wbk.Worksheets("Sheet1")
For i = 1 To Rows.Count
If Not IsEmpty(Cells(i, 1).Value) Then
if dicUniques.exists(cells(i,1).value) = false then
dicUniques.add cells(i,1).value, cells(i,1).value
end if
End If
Next i
End With
s_wbk.Close
for each var in dicUniques.keys
strSearch = strSearch & ", " & var
next var
searchItem = Split(strSearch, ",")
That's the quick and dirty solution. Since the keys are unique you could probably use them by themselves, without putting them together in the string first.
By the way: First of all, you shoudl specify which cells you use. Sometimes you start the macro form another worksheet and then it will use the cells there, if no parent worksheet is given for the cells object.
Second, it is important to specify you want to use the cells value for the dictionary, since a dictionary object can contain anything. So if you don't use cells(x,y).value the object will contain the cell itself.
edit: Corrected typo in the routine.
Unique Column To Array
Option Explicit
Sub removeDuplicates()
Const strFile = "...\Desktop\xl files min\src.xlsm"
Const SheetName As String = "Sheet1"
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const FirstRow As Long = 2
Dim s_wbk As Workbook
Dim SourceArray, WorkArray, searchItem
Set s_wbk = Workbooks.Open(strFile)
SourceArray = copyColumnToArray(s_wbk.Worksheets(SheetName), _
FirstRow, SourceColumn)
s_wbk.Close
If Not IsArray(SourceArray) Then Exit Sub
WorkArray = Application.Transpose(SourceArray) ' only up to 65536 elements.
searchItem = getUniqueArray(WorkArray)
End Sub
Function copyColumnToArray(SourceSheet As Worksheet, _
FirstRowNumber As Long, ColumnNumberLetter As Variant) As Variant
Dim rng As Range
Dim LastRowNumber As Long
Set rng = SourceSheet.Columns(ColumnNumberLetter).Find(What:="*", _
LookIn:=xlFormulas, Searchdirection:=xlPrevious)
If rng Is Nothing Then Exit Function
Set rng = SourceSheet.Range(SourceSheet _
.Cells(FirstRowNumber, ColumnNumberLetter), rng)
If Not rng Is Nothing Then copyColumnToArray = rng
End Function
Function getUniqueArray(SourceArray As Variant, _
Optional Transpose65536 As Boolean = False) As Variant
' Either Late Binding ...
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' ... or Early Binding:
' VBE > Tools > References > Microsoft Scripting Runtime
'Dim dict As Scripting.Dictionary: Set dict = New Scripting.Dictionary
Dim i As Long
For i = LBound(SourceArray) To UBound(SourceArray)
If SourceArray(i) <> Empty Then
dict(SourceArray(i)) = Empty
End If
Next i
' Normal: Horizontal (Row)
If Not Transpose65536 Then getUniqueArray = dict.Keys: GoTo exitProcedure
' Transposed: Vertical (Column)
If dict.Count <= 65536 Then _
getUniqueArray = Application.Transpose(dict.Keys): GoTo exitProcedure
' Transpose only supports up to 65536 items (elements).
MsgBox "Source Array contains '" & dict.Count & "' unique values." _
& "Transpose only supports up to 65536 items (elements).", vbCritical, _
"Custom Error Message: Too Many Elements"
exitProcedure:
End Function

Resources