Related
I'm New to VBA and finding my way around. I'm writing a macro which searches column 6 for postage method and enters the correct postage price (which often changes) in column 14.
I've started to use 'if statements' and it's working. However there are a total of 28 postage methods (and that could increase a few) I know there are shortcuts. I'm thinking this could possibly be done in an array which I could later edit as price changes
Sub Amend()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
Lastrow = Sheets(2).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
'postage
If Sheets(2).Cells(row, 6).Value = "Austria Tracked" Then
Sheets(2).Cells(row, 14).Value = 4.79
End If
If Sheets(2).Cells(row, 6).Value = "International DDU shipments" Then
Sheets(2).Cells(row, 14).Value = 4.27
End If
If Sheets(2).Cells(row, 6).Value = " Landmark Belgium DDU" Then
Sheets(2).Cells(row, 14).Value = 4.27
End If
If Sheets(2).Cells(row, 6).Value = "France Untracked" Then
Sheets(2).Cells(row, 14).Value = 2.42
End If
If Sheets(2).Cells(row, 6).Value = "GLS France" Then
Sheets(2).Cells(row, 14).Value = 5.27
End If
I want to keep it simple but should I be using an array or a vlookup?
Multiple Criteria Lookup
Copy the code into a standard module (e.g. Module1).
Adjust the values in the constants section.
For each Method you add, you have to add the Price in the same position.
The Code
Option Explicit
Sub Amend()
Const Proc As String = "Amend"
On Error GoTo cleanError
' Define Constants.
Const SheetNameOrIndex As Variant = 2 ' Sheet Name is safer than index.
Const FirstRow As Long = 2
Const MethodColumn As Variant = 6 ' e.g. 6 or "F"
Const PriceColumn As Variant = 14 ' e.g. 14 or "N"
Dim MethodValue As Variant, PriceValue As Variant
MethodValue = Array("Austria Tracked", _
"International DDU shipments", _
"Landmark Belgium DDU", _
"France Untracked", _
"GLS France")
PriceValue = Array(4.79, _
4.27, _
4.27, _
2.42, _
5.27)
' Check if MethodValue and PriceValue Arrays have the same number
' of elements (columns).
Dim ubV As Long: ubV = UBound(MethodValue)
If UBound(PriceValue) <> ubV Then Exit Sub
' Copy values of Method and Price Columns to Method and Price Arrays.
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(SheetNameOrIndex)
Dim rng As Range
Set rng = ws.Columns(MethodColumn).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Dim Method As Variant
Method = ws.Range(ws.Cells(FirstRow, MethodColumn), rng).Value
Set rng = Nothing
Dim ubMP As Long: ubMP = UBound(Method)
Dim Price As Variant
Price = ws.Cells(FirstRow, PriceColumn).Resize(ubMP).Value
' Modify values in Price Array.
Dim i As Long, j As Long
For i = 1 To ubMP
For j = 0 To ubV
If Method(i, 1) = MethodValue(j) Then
Price(i, 1) = PriceValue(j)
Exit For
End If
Next j
Next i
Erase Method
' Write values of Price Array to Price Range.
ws.Cells(FirstRow, PriceColumn).Resize(ubMP).Value = Price
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
Try the next code, please. You only must maintain arrPrices array. Each product must be separated by a comma, and product to be separated by its price using "|". You can extend the array as you need. The array can also be loaded on the fly if you will have two rows in a sheet keeping the product name on first and the price on the second:
Sub Amend()
Dim sh As Worksheet, row As Long, El As Variant, Lastrow As Long, arrPrices As Variant
Dim arrInt As Variant
Set sh = ActiveSheet ' use here your sheet
Lastrow = sh.Sheets(2).Cells(Rows.count, "D").End(xlUp).row
arrPrices = Split("Austria Tracked|4.79,International DDU shipments|1.27,Landmark Belgium DDU|4.27,France Untracked|2.42,GLS France|5,27", ",")
Application.ScreenUpdating = False
If Lastrow > 1 Then
For row = 2 To Lastrow
For Each El In arrPrices
arrInt = Split(El, "|")
If Sheets(2).Cells(row, 6).value = arrInt(0) Then
sh.Sheets(2).Cells(row, 14).value = arrInt(1)
Exit For
End If
Next
Next row
End If
Application.ScreenUpdating = True
End Sub
I used your code like model, but take care, please: You calculate the last row for column D:D and process the date in column 6 (F:F). Please, check and be sure that the last row calculation is appropriate and correlate them if necessary...
I supposed that each product may appear only once during iteration. Is this assumption correct?
I am looping through ArrayDestination through two columns (customer name and process number).
I am looping through ArraySourceData to find matches (invoice number and amount) for the above search criteria.
If there is a match it gets copied to the array and once both loops finish the results get copied to the worksheet.
So far it works except that the loop is only returning the first match.
If a customer has multiple identical process numbers the loop only returns the first match for all of them.
My b variable looks a bit static and I tried to cheer it up with b = b + 1.
For simplicity I didn't post creating the array part. It works. If needed I can provide it.
Sub search_loop_arrray()
For a = 2 To UBound(ArraySourceData)
varCustomerName = ArraySourceData(a, 3)
varProcessNumber = ArraySourceData(a, 5)
For b = 2 To UBound(ArrayDestination)
If ArrayDestination(b, 3) = varCustomerName And _
ArrayDestination(b, 8) = varProcessNumber Then
ArrayDestination(b, 9) = ArraySourceData(a, 11)
ArrayDestination(b, 10) = ArraySourceData(a, 12)
Exit For
End If
Next b
Next a
'transfer data (invoice number and amount) from ArrayDestination to wsDestination (Column 9 and 10)
For a = 2 To UBound(ArraySourceData)
For b = 9 To 10
wsDestination.Cells(a, b).Value = ArrayDestination(a, b)
Next b
Next a
End Sub
02/02/2020
I rewrote the code in a nested for loop without the array. This code works. The problem is there are duplicated process numbers in my source data.
In my example I "cut and paste" the already found process numbers in a sheet called coincidences. It is working BUT I was looking to parse everything into an array due to dealing with 100.000+ rows and 20+ columns.
I don't know if my "copy to temporary coincidences sheet" would make sense in the array?
Sub find_invoice()
Dim wsSourceData As Worksheet
Dim wsResults As Worksheet
Dim wsCoincidences As Worksheet
Dim varCustomer As String
Dim varProcessNumber As Long
Dim varInvoiceNumber As Long
Dim varSDlastrow As Integer
Dim varRElastrow As Long
Dim varCIlastrow As Long
Dim varCounterResults As Long
Set wsResults = ThisWorkbook.Sheets("RESULTS")
Set wsSourceData = ThisWorkbook.Sheets("SOURCEDATA")
Set wsCoincidences = ThisWorkbook.Sheets("COINCIDENCES")
varSDlastrow = wsSourceData.Cells(Rows.Count, 1).End(xlUp).Row
varRElastrow = wsResults.Cells(Rows.Count, 1).End(xlUp).Row
varCIlastrow = wsCoincidences.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To varRElastrow
varCustomer = wsResults.Cells(i, 1)
varProcessNumber = wsResults.Cells(i, 2)
For j = 2 To varSDlastrow
If wsSourceData.Cells(j, 1) = varCustomer And wsSourceData.Cells(j, 2) = varProcessNumber Then
wsResults.Cells(i, 3) = wsSourceData.Cells(j, 3)
wsResults.Cells(i, 4) = wsSourceData.Cells(j, 4)
wsCoincidences.Rows(varCIlastrow).EntireRow.Value = wsSourceData.Rows(j).EntireRow.Value
wsSourceData.Rows(j).EntireRow.Delete
varCIlastrow = varCIlastrow + 1
Exit For
End If
Next j
Next i
End Sub
I'm not sure you're logic is right. If you are saying you need to match 2 parameters and several entities can contain those two parameters, then I don't see how you can do anything other than find either the first or last occurrence. Wouldn't you need a third parameter to distinguish the matches?
You'll see in the sample code below, I've assumed that the source data has the list of invoices which are sequential and the destination data has the duplicate customer and process parameters. In this case I've assumed that the invoice matching on the destination sheet should also be sequential, ie 2nd occurrence of duplicate means match the 2nd occurence of an invoice. So here, 'sequence' becomes the third parameter, but yours may be different.
It might also be easier to format your data into a hierarchical structure:
customer -> process -> invoice
so you can see what's going on a little easier. Classes are ideal for this. Your code is hard to follow as that Exit For will guarantee a first match only, and the transfer loop iterates on the upperbound of the ArraySourceData array and yet processes the ArrayDestination (I can't see what you're trying to do there, unless it's an error).
To show you what I mean, create three classes (Insert~>Class Module) called cCustomer, cProcess and cInvoice. Add the following code to each:
cCustomer
Option Explicit
Public Name As String
Public Processes As Collection
Public Sub AddInvoice(processNum As String, invoiceNum As String, invAmount As Double)
Dim process As cProcess
Dim invoice As cInvoice
On Error Resume Next
Set process = Processes(processNum)
On Error GoTo 0
If process Is Nothing Then
Set process = New cProcess
With process
.ProcessNumber = processNum
Processes.Add process, .ProcessNumber
End With
End If
Set invoice = New cInvoice
With invoice
.InvoiceNumber = invoiceNum
.Amount = invAmount
process.Invoices.Add invoice
End With
End Sub
Public Function GetProcess(num As String) As cProcess
On Error Resume Next
Set GetProcess = Processes(num)
End Function
Private Sub Class_Initialize()
Set Processes = New Collection
End Sub
cProcess
Option Explicit
Public ProcessNumber As String
Public Invoices As Collection
Public CurrentInvoiceCount As Long
Private Sub Class_Initialize()
Set Invoices = New Collection
End Sub
cInvoice
Option Explicit
Public InvoiceNumber As String
Public Amount As Double
Public ArrayIndex As Long
The following routine in your Module will output the data as I described above:
Dim customers As Collection
Dim customer As cCustomer
Dim process As cProcess
Dim invoice As cInvoice
Dim srcData As Variant, dstData As Variant
Dim output() As Variant
Dim i As Long
'Populate the source data array.
'Note: just an example here, use whatever array populating code you have.
With Sheet1 'I've put some dummy data in my Sheet1.
srcData = _
.Range( _
.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 12) _
.Value2
End With
'Populate the destination data array.
'Note: just an example here, use whatever array populating code you have.
With Sheet2 'I've put some dummy data in my Sheet2.
dstData = _
.Range( _
.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 10) _
.Value2
End With
'Convert source array to heirarchical collections.
Set customers = New Collection
For i = 1 To UBound(srcData, 1)
Set customer = Nothing: On Error Resume Next
Set customer = customers(CStr(srcData(i, 3))): On Error GoTo 0
If customer Is Nothing Then
Set customer = New cCustomer
With customer
.Name = CStr(srcData(i, 3))
customers.Add customer, .Name
End With
End If
customer.AddInvoice CStr(srcData(i, 5)), CStr(srcData(i, 11)), CDbl(srcData(i, 12))
Next
'Match destination array.
For i = 1 To UBound(dstData, 1)
Set customer = Nothing: On Error Resume Next
Set customer = customers(CStr(dstData(i, 3))): On Error GoTo 0
If Not customer Is Nothing Then
Set process = customer.GetProcess(CStr(dstData(i, 8)))
If Not process Is Nothing Then
With process
.CurrentInvoiceCount = .CurrentInvoiceCount + 1
If .CurrentInvoiceCount > .Invoices.Count Then
MsgBox "No further invoices for [cust=" & customer.Name & ";" & process.ProcessNumber & "]"
Else
Set invoice = .Invoices(.CurrentInvoiceCount)
invoice.ArrayIndex = i
End If
End With
End If
End If
Next
'Populate the output array.
ReDim output(1 To UBound(dstData, 1), 1 To 2)
For Each customer In customers
For Each process In customer.Processes
For Each invoice In process.Invoices
With invoice
If .ArrayIndex > 0 Then
output(.ArrayIndex, 1) = .InvoiceNumber
output(.ArrayIndex, 2) = .Amount
End If
End With
Next
Next
Next
'Write array to worksheet
Sheet2.Cells(2, 9).Resize(UBound(output, 1), UBound(output, 2)).Value = output
Without seeing some sample data, it's difficult to be certain, but I suspect my point is: if only a combination of three of parameters makes something unique, then you'll need to match against those three parameters.
If you have 100,000 rows on the SOURCEDATA sheet and 10,000 rows of the RESULTS sheet then having 2 loops is 1,000,000,000 iterations. The efficient way is to use a dictionary object using a key constructed on your 2 match criteria (col1 and col2) joined by a character of your choice such a "~" (tilde) or "_" (underscore). Scan the SOURCEDATA sheet once to build a "look up" of key to row number. Then scan the RESULTS sheet once, concatenate the 2 fields as before and using the dictionary .exists(key) method to find a match will give you the relevant row number on SOURCEDATA. Here is some code to illustrate. I tested it with 100,000 source rows and 10,000 results rows of random data matching the keys and filling in col C and D on the RESULTS sheet take around 3 seconds. Add a sheet called RUNLOG for the performance figures. It looks a lot of code but much of it is logging.
Option Explicit
Sub find_invoice2()
Const MSG As Boolean = False ' TRUE to show message boxes
Const RUNLOG As Boolean = False ' TRUE to log matches, no match etc
Dim wb As Workbook, start As Single, finish As Single
start = Timer
Set wb = ThisWorkbook
' set up sheets
Dim wsSourceData As Worksheet, wsResults As Worksheet, wsLog As Worksheet, wsMatch
With wb
Set wsResults = .Sheets("RESULTS")
Set wsSourceData = .Sheets("SOURCEDATA")
Set wsMatch = .Sheets("COINCIDENCES")
Set wsLog = .Sheets("RUNLOG")
End With
' find last row of source and results
Dim lastRowSource As Long, lastRowResults As Long, lastRowLog As Long, lastRowMatch
lastRowSource = wsSourceData.Cells(Rows.Count, 1).End(xlUp).Row
lastRowResults = wsResults.Cells(Rows.Count, 1).End(xlUp).Row
lastRowMatch = wsMatch.Cells(Rows.Count, 1).End(xlUp).Row
' set up log sheets
wsLog.Cells.Clear
wsLog.Range("A1:E1") = Array("Source Row", "Result Row", "Customer~Process", "Message", "Date Time")
wsLog.Cells(2, 4) = "Started"
wsLog.Cells(2, 5) = Time
lastRowLog = 3
' create lookup from Source
' key = Name~ProcessID, value = array row
Dim dict As Object, sKey As String, iRow As Long
Set dict = CreateObject("scripting.dictionary")
With wsSourceData
For iRow = 2 To lastRowSource
sKey = CStr(.Cells(iRow, 1)) & "~" & CStr(.Cells(iRow, 2)) ' customer~process
If Len(sKey) > 1 Then ' skip blanks lines if any
If dict.exists(sKey) Then
dict.Item(sKey) = dict.Item(sKey) & "_" & CStr(iRow)
If MSG Then MsgBox "Ignoring duplicate key in Source Data " & sKey, vbCritical
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 0) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Source : Ignoring duplicate key "
.Offset(0, 4) = Time
End With
lastRowLog = lastRowLog + 1
End If
Else
dict.Add sKey, iRow
'Debug.Print "Dict add", sKey, iRow
End If
End If
Next
End With
If MSG Then MsgBox dict.Count & " records added to dictionary"
wsLog.Cells(lastRowLog, 4) = "Dictionary Built Keys Count = " & dict.Count
wsLog.Cells(lastRowLog, 5) = Time
lastRowLog = lastRowLog + 1 ' blank line to seperate results
' scan results sheet
Dim sDict As String, countMatch As Long, countNoMatch As Long, sMsg As String
Dim ar As Variant, i As Long
countMatch = 0: countNoMatch = 0
Application.ScreenUpdating = False
With wsResults
For iRow = 2 To lastRowResults
sKey = CStr(.Cells(iRow, 1)) & "~" & CStr(.Cells(iRow, 2)) ' customer~process
If Len(sKey) > 1 Then 'skip blanks lines if any
If dict.exists(sKey) Then
' split string to get multiple lines
sDict = dict(sKey)
ar = Split(sDict, "_")
.Cells(iRow, 3).Value = UBound(ar) + 1
For i = 0 To UBound(ar)
.Cells(iRow, 4).Offset(0, i) = ar(i)
Next
lastRowMatch = lastRowMatch + 1
countMatch = countMatch + 1
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 0) = sDict
.Offset(0, 1) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Match - Source record deleted"
.Offset(0, 4) = Time
End With
lastRowLog = lastRowLog + 1
End If
'Debug.Print iRow,sDict, sKey,
Else
' no match
If MSG Then MsgBox "Results Row " & iRow & ": NO match for " & sKey, vbExclamation, "NO match"
countNoMatch = countNoMatch + 1
If RUNLOG Then
With wsLog.Cells(lastRowLog, 1)
.Offset(0, 1) = iRow
.Offset(0, 2) = sKey
.Offset(0, 3) = "Results : NO match"
.Offset(0, 4) = Time
.EntireRow.Interior.Color = vbYellow
End With
.Cells(iRow, 3).Resize(1, 2).Interior.Color = vbYellow
lastRowLog = lastRowLog + 1
'Debug.Print iRow, sDict, sKey,
End If
End If
End If
Next
End With
Application.ScreenUpdating = True
wsLog.Cells(lastRowLog, 4) = "Program Ended Rows Scanned = " & lastRowResults - 1
wsLog.Cells(lastRowLog, 5) = Time
wsLog.Columns.AutoFit
wsLog.Activate
wsLog.Columns("A:B").HorizontalAlignment = xlCenter
wsLog.Range("A1").Select
' result
finish = Timer
sMsg = "Matched = " & countMatch & vbCrLf _
& "NO match = " & countNoMatch & vbCrLf _
& "Run time (secs) = " & Int(finish - start)
MsgBox sMsg, vbInformation, "Results"
End Sub
After a lot of googling and trying I am asking you for help regarding the following Problem.
Worksheet 1 (Database) has the ID's and a lot of Information in Column D
Worksheet 2 (Skills) has the ID's in Row 1 and all respective skills in the rows below the column for each ID.
Worksheet 3 (Output) is needed to populate Listboxes and Graphs and can be considered empty
For Illustration purposes: http://imgur.com/a/Nt88C
Via comboboxes, the skill the user is looking for is selected. This Skill then needs to be matched against the skills of each ID on Worksheet 2.
If a match is found, the respective ID shall be found on Worksheet 1 and certain Information from there copied to Worksheet 3.
My take on this has been to find each ID in Worksheet 1, match it with all ID's on Worksheet 2 and look through the respective rows for a match. However, every more efficient way is welcome.
Here my code:
The comboboxes
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws1, ws2, ws3, ws4 As Worksheet
Set ws1 = wb.Worksheets("Meta DB")
Set ws2 = wb.Worksheets("Criteria")
Set ws3 = wb.Worksheets("Supplier Criteria TreeView")
Set ws4 = wb.Worksheets("Supplier Skills")
'1. - - get all Suppliers for the selected Input
'Redefine for clarity
Dim strFind As String
'1.0. - - Clear previously used ranges
ws3.Range("A2:L28").Clear
ws3.Range("A30:L100").Clear
ws3.Range("V2:V20").Clear
'1.1. - - Get value to search for and range to go through (depending on combobox selections)
If Me.comboProduct.ListIndex = -1 And Me.comboSubGroup.ListIndex = -1 And Me.comboCG.ListIndex <> -1 Then
strFind = Me.comboCG.value
ElseIf Me.comboProduct.ListIndex = -1 And Me.comboSubGroup.ListIndex <> -1 And Me.comboCG.ListIndex <> -1 Then
strFind = Me.comboSubGroup.value
ElseIf Me.comboProduct.ListIndex <> -1 And Me.comboSubGroup.ListIndex <> -1 And Me.comboCG.ListIndex <> -1 Then
strFind = Me.comboProduct.value
End If
Try 1:
Dim rng1, rng2 As Range
Dim lRow, j, k As Long
Dim IDrow As String
'Paste starting at row 2 or 30 in ws3, respectively (Active / Inactive)
j = 2
k = 30
For Each rng1 In ws1.Range("D4:D500")
If Rng <> "" Then
For Each rng2 In ws4.Range("A1:ZZ1")
If rng2 <> "" Then
If rng1.value = rng2.value Then
For lRow = 2 To ws4.UsedRange.Rows.Count
IDrow = ws4.Cells(lRow, rng2).value
If InStr(1, IDrow, strFind, vbTextCompare) > 0 Then
'Check for active Supplier in current Database-row
If ws1.Range("E" & rng1) = "Yes" Then
'Copy row of Database to row j of ws3 then increment j
ws1.Range("B" & rng1 & ":" & "E" & rng1).Copy Destination:=ws3.Range("B" & j & ":" & "E" & j) 'Copy Name, Potential Supplier, ID, Active
j = j + 1
'ElseIf inactive Supplier, post further down from 30 onwards. Second listbox populates from there
ElseIf ws1.Range("E" & rng1) = "No" Then
ws1.Range("B" & rng1 & ":" & "E" & rng1).Copy Destination:=ws3.Range("B" & k & ":" & "E" & k) 'Copy Name, Potential Supplier, ID, Active
k = k + 1
Else
Exit Sub
End If
End If
Next lRow
End If
End If
Next rng2
End If
Next rng1
Try 2:
Dim IDAr, MyAr, TempAr As Variant
Dim lRow, lastRow, entryrow, LCol, e As Long
Dim ColumnLetter As String
entryrow = ws3.Range("B" & Rows.Count).End(xlUp).row + 1
ws1LRow = ws1.Range("D" & ws1.Rows.Count).End(xlUp).row
IDAr = ws1.Range("D4:D" & lRow).value
Set f = ws4.Range("A1:ZZ1").Find(What:=IDAr, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
ColumnLetter = Split(f.Address, "$")(1)
lastRow = ws4.Range(ColumnLetter & "2:" & ColumnLetter & "50").End(xlUp).row
MyAr = ws4.Range(ColumnLetter & "1:" & ColumnLetter & lastRow).value
With ws3
'If IsArray(MyAr) Then
For i = LBound(MyAr) To UBound(MyAr)
TempAr = Split(MyAr(i, 1), "\")
For e = 0 To 2
TempAr(e) = ValueToCompare
If InStr(1, ValueToCompare, strFind, vbTextCompare) > 0 Then
ws3.Range("B" & entryrow).value = "Test if it works"
'.
'.
'.
End If
Next e
Next i
Thank you all in advance for any tips!
Sub CodeForLazyPoster()
Dim rIDs As Excel.Range
Dim ID As Excel.Range
Dim lFoundRow As Long
Set rIDs = Worksheets("Sheet1").Range("a1:a10")
For Each ID In rIDs
lFoundRow = FindRow(ID)
If lFoundRow > 0 Then
If FindSkill("Maths", Worksheets("Sheet2").Range("B" & lFoundRow)) Then
' Copy here
End If
End If
Next ID
End Sub
Function FindRow(strFind) As Long
FindRow = 0
On Error Resume Next
FindRow = Application.WorksheetFunction.Match( _
strFind, Worksheets("Sheet2").Range("a1:a10"), False)
End Function
Function FindSkill(strSkill As String, rngLookIn As Excel.Range) As Boolean
Dim tmp As Integer
FindSkill = False
On Error GoTo eHandle
tmp = Application.WorksheetFunction.Match(strSkill, rngLookIn, False)
FindSkill = True
Exit Function
eHandle:
End Function
I have an Excel file that contains contact email addresses, such as the below.
A B C
1 Shop Supervisor Assistant
2 A hulk.hogan#web.com freddie.mercury#web.com
3 B brian.may#web.com
4 C triple.h#web.com roger.taylor#web.com
5 D
6 E randy.orton#web.com john.deacom#web.com
I have created a userform where the user can select what role they want to email (Supervisor or Assistant) or they can email both if needed, and then there's code that takes the email addresses for those roles, opens a new email, and adds the email addresses into the "To" section. This code is as follows:
Private Sub btnEmail_Click()
Dim To_Recipients As String
Dim NoContacts() As String
Dim objOutlook As Object
Dim objMail As Object
Dim firstRow As Long
Dim lastRow As Long
ReDim NoContacts(1 To 1) As String
' Define the column variables
Dim Supervisor_Column As String, Assistant_Column As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
' Add in the column references to where the email addresses are, e.g. Supervisor is in column K
Supervisor_Column = "K"
Assistant_Column = "M"
' Clear the To_Recipients string of any previous data
To_Recipients = ""
' If the To Supervisor checkbox is ticked
If chkToSupervisor.Value = True Then
With ActiveSheet
' Get the first and last rows that can be seen with the filter
firstRow = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Row
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' For every row between the first and last
For Row = firstRow To lastRow
' Check if the row is visible - i.e. if it is included in the filter
If Rows(Row).Hidden = False Then
' If it is visible then check to see whether there is data in the cell
If Not IsEmpty(Range(Supervisor_Column & Row).Value) And Range(Supervisor_Column & Row).Value <> 0 Then
' If there is data then add it to the list of To_Recipients
To_Recipients = To_Recipients & ";" & Range(Supervisor_Column & Row).Value
Else
' See whether the shop is already in the array
If UBound(Filter(NoContacts, Range("F" & Row).Value)) = -1 Then
' If it isn't then add it to the array
NoContacts(UBound(NoContacts)) = Range("F" & Row).Value
ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1) As String
End If
End If
End If
' Go onto the next row
Next Row
End With
End If
' If the To Assistant checkbox is ticked
If chkToAssistant.Value = True Then
With ActiveSheet
' Get the first and last rows that can be seen with the filter
firstRow = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Row
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' For every row between the first and last
For Row = firstRow To lastRow
' Check if the row is visible - i.e. if it is included in the filter
If Rows(Row).Hidden = False Then
' If it is visible then check to see whether there is data in the cell
If Not IsEmpty(Range(Assistant_Column & Row).Value) And Range(Assistant_Column & Row).Value <> 0 Then
' If there is data then add it to the list of To_Recipients
To_Recipients = To_Recipients & ";" & Range(Assistant_Column & Row).Value
Else
' See whether the shop is already in the array
If UBound(Filter(NoContacts, Range("F" & Row).Value)) = -1 Then
' If it isn't then add it to the array
NoContacts(UBound(NoContacts)) = Range("F" & Row).Value
ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1) As String
End If
End If
End If
' Go onto the next row
Next Row
End With
End If
With objMail
.To = To_Recipients
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
' Close the User Form
Unload Me
End Sub
What I want to be able to do is get is so that if there isn't a contact, for example in shop "D" in the above example, a message box appears saying that there is no contact. To do this I have started to use the array:
NoContacts
Which, as you can see in the code from the above:
' See whether the shop is already in the array
If UBound(Filter(NoContacts, Range("F" & Row).Value)) = -1 Then
' If it isn't then add it to the array
NoContacts(UBound(NoContacts)) = Range("F" & Row).Value
ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1) As String
End if
Has the shop letter entered into it if there isn't a contact, for example if there isn't a Supervisor like shop "B" in the example. Because this code looks at all the Supervisors, i.e. it runs down column B adding the email addresses to the "To_Recipients" variable if there is an email address and adding the shop to the "NoContacts" array if there isn't, then goes on to the Assistants, I need to know how to delete an item from the array.
For example, the above code will add Shop "B" into the array because it doesn't have a Supervisor, however because it has an Assistant I need to remove Shop "B" from the array when it runs the Assistant code, whereas Shop "D" will stay in the array because it has neither Supervisor or Assistant - Remember that I am trying to display a list of Shops that have no contact and so are not included in the email.
This are makes sense in my mind, however please let me know if I have not explained it clearly.
So, to clarify, how can I remove a specific item from an array?
Your code could be simplified by only looping over the rows once, and checking both supervisor and assistant at the same time:
Private Sub btnEmail_Click()
'Add in the column references to where the email addresses are
Const Supervisor_Column = "K"
Const Assistant_Column = "M"
Dim To_Recipients As String
Dim NoContacts() As String
Dim objOutlook As Object
Dim objMail As Object
Dim firstRow As Long, lastRow As Long
Dim doSup As Boolean, doAssist As Boolean, eSup, eAssist
Dim bHadContact As Boolean
ReDim NoContacts(1 To 1) As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
doSup = chkToSupervisor.Value
doAssist = chkToAssistant.Value
To_Recipients = ""
' If either checkbox is ticked
If doSup Or doAssist Then
With ActiveSheet
firstRow = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Row
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For Row = firstRow To lastRow
If Not Rows(Row).Hidden Then
bHadContact = False
eSup = Trim(.Cells(Row, Supervisor_Column))
eAssist = Trim(.Cells(Row, Assistant_Column))
If Len(eSup) > 0 And doSup Then
To_Recipients = To_Recipients & ";" & eSup
bHadContact = True
End If
If Len(eAssist) > 0 And doAssist Then
To_Recipients = To_Recipients & ";" & eAssist
bHadContact = True
End If
'no assistant or supervisor - add the shop
If Not bHadContact Then
NoContacts(UBound(NoContacts)) = .Cells(Row, "F").Value
ReDim Preserve NoContacts(1 To UBound(NoContacts) + 1)
End If
End If 'not hidden
Next Row
End With
End If
With objMail
.To = To_Recipients
.Display
End With
If UBound(NoContacts) > 1 Then
MsgBox "One or more stores had no contacts:" & vbCrLf & Join(NoContacts, vbLf), _
vbExclamation
End If
Set objOutlook = Nothing
Set objMail = Nothing
' Close the User Form
Unload Me
End Sub
To answer your specific question though, there's no built-in way to remove one or more items from an array. You would build a function or sub to do that: loop over the array and copy its items to a second array, excluding the item(s) to be removed.
Example:
Sub Tester()
Dim arr
arr = Split("A,B,C,D", ",")
Debug.Print "Before:", Join(arr, ",")
RemoveItem arr, "A"
Debug.Print "After:", Join(arr, ",")
End Sub
Sub RemoveItem(ByRef arr, v)
Dim rv(), i As Long, n As Long, ub As Long, lb As Long
lb = LBound(arr): ub = UBound(arr)
ReDim rv(lb To ub)
For i = lb To ub
If arr(i) <> v Then
rv(i - n) = arr(i)
Else
n = n + 1
End If
Next
'check bounds before resizing
If (ub - n) >= lb Then ReDim Preserve rv(lb To ub - n)
arr = rv
End Sub
I am working on a piece of code that creates an array and populates it based on the contents of a column in an Excel Sheet. I would then like to use this array to add or delete Excel Sheets.
Actions I'd like the Macro to do:
If the sheet name matches an array value do nothing
If there is no sheet name for an array value, add a sheet and name it the array value
If there is a sheet that does not exist in the array, delete the sheet.
I can populate the array with the values, but I am having a difficult time adding/deleting sheets based on the array values. I have noted the spot I am stuck in my code.
Sub CheckCities()
'Declare Variable
Dim rngCities As Range
Dim rngCityName As Range
Dim ws As Worksheet
Dim arrCityName() As String
Dim counter As Integer
Dim intWsCount As Integer
'Reset and erase array at start of program. Allows for proper data in array
Erase arrCityName
'initialize counter variable
counter = 0
'Set Range Name for wsData Customers
With wsAllCities1.Range("A2")
Set rngCities = Range(.Offset(0, 0), .End(xlDown))
End With
''''''''''''''''''''''''''''''''''''''''''''
' For Loop through Each City in rngCities
' adds current rngCities cell value to array
''''''''''''''''''''''''''''''''''''''''''''
For Each rngCityName In rngCities.Cells
'Debug.Print rngCityName.Value ' Print the values of each cell
counter = counter + 1 'Step up counter variable by 1
ReDim Preserve arrCityName(0 To rngCities.Count)
arrCityName(counter) = rngCityName.Value 'use the counter variable to create Array(#)
Next rngCityName
'''''''''''''''''''''''''''''''''''''''''''''''''''
'Test to verify Array was populated with City Names
'''''''''''''''''''''''''''''''''''''''''''''''''''
'wsAllCities1.Range("E2").Value = arrCityName(0)
'wsAllCities1.Range("E3").Value = arrCityName(1)
'wsAllCities1.Range("E4").Value = arrCityName(2)
'wsAllCities1.Range("E5").Value = arrCityName(3)
'wsAllCities1.Range("E6").Value = arrCityName(4)
'wsAllCities1.Range("E7").Value = arrCityName(5)
'wsAllCities1.Range("E8").Value = arrCityName(6)
'wsAllCities1.Range("E9").Value = arrCityName(7)
'wsAllCities1.Range("E10").Value = arrCityName(8)
'wsAllCities1.Range("E11").Value = arrCityName(9)
''''''''''''''''''''''''''''''''''''''''''''
' Loop statement to check sheet names
' adds or deletes sheets via arrCityName values
''''''''''''''''''''''''''''''''''''''''''''
''''STUCK ON CODE BELOW''''''''''''''''
''''STUCK ON CODE BELOW''''''''''''''''
''''STUCK ON CODE BELOW''''''''''''''''
''''STUCK ON CODE BELOW''''''''''''''''
''''STUCK ON CODE BELOW''''''''''''''''
''''STUCK ON CODE BELOW''''''''''''''''
intWsCount = ThisWorkbook.Worksheets.Count 'Count Number of Worksheets in this workbook
For Each ws In ThisWorkbook.Worksheets
counter = 0 'set variable
Do
ws.Activate 'activate the next worksheet in the look
If ws.Name <> "AllCities" Then
For Each arrayItem In arrCityName
If arrCityName = ws.Name Then
Debug.Print "City Name Found!"
ElseIf arrCityName <> ws.Name Then
End If
Next
Debug.Print "This city, " & ws.Name & ", does not exist in city list"
End If
Loop Until intWsCount 'Loop (x) number of times. X is determinted by variable intWsCount
Next
End Sub
You can run two separate loops. One loop to add sheets. One loop to delete sheets:
Sub dural()
Dim DesiredSheets(1 To 3) As String
Dim KillIt As Boolean, AddIt As Boolean
DesiredSheets(1) = "Sheet1"
DesiredSheets(2) = "Sheet2"
DesiredSheets(3) = "Whatever"
For Each sh In Sheets
KillIt = True
v = sh.Name
For Each a In DesiredSheets
If v = a Then
KillIt = False
End If
Next a
If KillIt Then sh.Delete
Next sh
For Each a In DesiredSheets
AddIt = True
For Each sh In Sheets
If a = sh.Name Then
AddIt = False
End If
Next sh
If AddIt Then
Sheets.Add
ActiveSheet.Name = a
End If
Next a
End Sub
Untested:
Sub CheckCities()
'Declare Variable
Dim rngCities As Range
Dim rngCityName As Range
Dim ws As Worksheet
Dim arrCityName() As String
Dim counter As long
Dim x as long, nm as string
With wsAllCities1
Set rngCities = .Range(.Range("A2").Offset(0, 0), _
.Range("A2").End(xlDown))
End With
ReDim Preserve arrCityName(1 To rngCities.Cells.Count)
counter=0
For Each rngCityName In rngCities.Cells
counter = counter + 1
arrCityName(counter) = rngCityName.Value
Next rngCityName
for x=1 to counter
nm = arrCityName(x)
set ws = nothing
on error resume next 'ignore error if no sheet found
set ws = thisworkbook.sheets(nm)
on error goto 0 'stop ignoring errors
if ws is nothing then
set ws = thisworkbook.worksheets.add()
ws.Name = nm
debug.print "Added sheet '" & nm & "'"
else
debug.print "Sheet '" & nm & "' already exists"
end if
next x
End Sub
Try this function. It does exactly what you need.
Public Function Test()
Dim wks, xlWSH As Worksheet
Dim myRange, Cell As Range
Dim ProtectIt As Boolean
'Refer to sheet name where you save your sheet names list
Set wks = Worksheets("SheetName")
With wks
'Refer to first cell where your sheet names list starts. Here is "A1"
Set myRange = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
For Each xlWSH In ActiveWorkbook.Worksheets
For Each Cell In myRange
'If sheet name is in your list then set DoIt to False
If xlWSH.Name = Cell.Value Then
DoIt = False
Exit For
Else
DoIt = True
End If
Next Cell
If DoIt = True Then
With xlWSH
'Do Some Actions With Sheet
End With
End If
Next xlWSH
End Function