Help with Formula / VBA to extract Information from an Array
Hi all
I have a specific task I need to program and I am a little stuck on how to do that most efficiently - using FUNCTIONS and/or VBA.
I have a list of Suppliers (B3:B22), by name, that each supply one or more products, in this case fruit(s) (as shown in array D3:H22).
The main supplier of a fruit may be indicated by the bold fruit name (D3, D9; D11, E5, E8, E9, E10, as shown in the attached Excel File), but this is not the case at all times (i.e. the bold indication is not mandatory).
The allocation might be sloppy - a fruit might be listed twice (e.g. Orange in D5 and F5 - highlighted), which needs to be handled correctly).
Based on the list of all products (fruits) delivered (J3:J30), I would like a single column (K3:K30) which indicates the Main Suppliers - this column marked in red is supposed to be calculated dynamically.
The rules for this column (K3:K30) are:
- If there is only one supplier for a fruit, no matter if that fruit is bold or not, this supplier name is shown in this column.
- If there are more than one supplier for a fruit, if none of the fruits are bold or more than one of the fruits are bold, then the text "No Main Supplier" followed by all supplier names in bracket, separated by a semicolon, is shown.
- If there are more that one supplier for a fruit and only one fruit is bold, then this supplier name is shown in this column.
This might be too complex to do?
Note that I have VBA code to test for bold, which is:
Function ISBOLD(CellRef As Range)
ISBOLD = CellRef.Font.Bold
End Function
This might be of use, but implementations that do not use it are fine as well.
Re: Help with Formula / VBA to extract Information from an Array
VBA solution.
Hit arrow "CLICK HERE" to generate list
code:
PHP Code:
Option Explicit Sub FindSuppliers() Dim lr&, i&, j&, s, rng Dim dic As Object, key, bol As Boolean, sup As String Set dic = CreateObject("Scripting.Dictionary") lr = Cells(Rows.Count, "B").End(xlUp).Row rng = Range("B3:H" & lr).Value For i = 1 To UBound(rng) For j = 3 To UBound(rng, 2) If rng(i, j) <> "" Then bol = Cells(i + 2, j + 1).Font.Bold sup = rng(i, 1) & IIf(bol, "@", "") If Not dic.exists(rng(i, j)) Then dic.Add rng(i, j), sup Else dic(rng(i, j)) = dic(rng(i, j)) & ";" & sup End If End If Next Next Range("J3:K10000").ClearContents Range("J3").Resize(dic.Count, 2).Value = WorksheetFunction.Transpose(Array(dic.keys, dic.items)) rng = Range("K3:K" & dic.Count + 2).Value For i = 1 To UBound(rng) s = Split(rng(i, 1), "@") Select Case UBound(s) Case 2 rng(i, 1) = "No Main Supplier (" & Replace(rng(i, 1), "@", "") & ")" Case 1 s = Split(rng(i, 1), ";") For j = 0 To UBound(s) If Right(s(j), 1) = "@" Then rng(i, 1) = Replace(s(j), "@", "") Exit For End If Next Case 0 If InStr(1, rng(i, 1), ";") Then rng(i, 1) = "No Main Supplier (" & rng(i, 1) & ")" End Select Next Range("K3:K" & dic.Count + 2).Value = rng End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks