Re: Reading multiple worksheets and populating a pull down box
This code will add two sheets to your workbook:
1.Products
2.Services
It then creates named ranges that are populated with the company names that offer each. Finally, it adds data validation to the MasterMatrix that has all the companies that offer those products and services. I noticed that you had some repeated items in your list. This code doesn't bother getting rid of those. I figured maybe this was just sample data, and your real spreadsheet didn't have this limitation.
I put all the sub routines into a macro called Controller(). That is the only one you need to run.
For those that are interested, I found a neat way to get around the non-alpha numeric character limitation in Named Ranges. I use an INDIRECT() and an HLOOKUP(), and simply assign each product/service a code. Then I can use Name = Service + i to ensure that I get the right values back.
I didn't go overboard proofing it, so it may be a bit buggy, especially if you go about deleting rows or something. Let me know how it works with your actual spreadsheet.
Finally, it may run rather slowly on 79 sheets. So, hold tight while the loops process.
Sub Controller()
Call SetupServices
Call SetupProducts
Sheets("MasterMatrix").Select
Range("A1").Select
Call ServiceValidation
Call ProductValidation
End Sub
Sub SetupProducts()
Dim ws As Worksheet
Dim x As Integer
Dim y As Integer
Dim rng As Range
Dim c As Range
Dim c2 As Range
Dim Service As String
Dim a As Integer
Dim b As Integer
x = 2
y = 1
a = 1
b = 1
AddSheetIfMissing1 ("Products")
Sheets("Products").Cells.Clear
Call CreateProducts
Call DeleteProductNames
For b = 1 To 39
Product = Sheets("Products").Cells(a, b).Value
For Each ws In Worksheets
If ws.Name <> "MasterMatrix" And ws.Name <> "Services" And ws.Name <> "Products" Then
Set rng = ws.Range("A9:A34")
For Each c2 In rng
If c2.Value = Product And c2.Offset(0, 3).Value = "X" Then
Sheets("Products").Cells(x, b) = ws.Name
x = x + 1
Else
End If
Next c2
Else
End If
Next ws
x = 2
y = y + 1
b = b + 1
Next b
Call MakeNamedRanges1
End Sub
Function AddSheetIfMissing1(Name As String) As Worksheet
'Thanks Batman! http://www.ozgrid.com/forum/showthread.php?t=53141&page=1
On Error Resume Next
Set AddSheetIfMissing1 = ThisWorkbook.Worksheets(Name)
If AddSheetIfMissing1 Is Nothing Then
Set AddSheetIfMissing1 = ThisWorkbook.Worksheets.Add
AddSheetIfMissing1.Name = Name
End If
End Function
Sub CreateProducts()
Sheets("MasterMatrix").Select
Range("A9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Products").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=True
End Sub
Sub MakeNamedRanges1()
Dim rng As Range
Dim d As Integer
Dim ColCount As Integer
Dim namestr As String
Dim lastrow As Integer
Dim lastcol As Integer
Dim e As Range
Dim f As Integer
With Sheets("Products").Rows("2:2")
.Insert Shift:=xlDown
End With
lastcol = Sheets("Products").Cells(1, 255).End(xlToLeft).Column
f = 1
For Each e In Sheets("Products").Range(Cells(2, 1), Cells(2, lastcol))
e.Value = "Product" & f
f = f + 1
Next e
For d = 1 To lastcol
namestr = Sheets("Products").Cells(2, d).Value
lastrow = Sheets("Products").Cells(65000, d).End(xlUp).Row
Cells(3, d).Resize(lastrow - 1).Name = namestr
Next d
End Sub
Sub DeleteProductNames()
'Thanks Mark O'Brian http://www.mrexcel.com/archive/VBA/31227.html
Dim nm As Name
On Error Resume Next
For Each nm In ActiveWorkbook.Names
If nm.RefersToRange.Worksheet.Name = "Products" Then
nm.Delete
End If
Next nm
End Sub
Sub SetupServices()
Dim ws As Worksheet
Dim x As Integer
Dim y As Integer
Dim rng As Range
Dim c As Range
Dim c2 As Range
Dim Service As String
Dim a As Integer
Dim b As Integer
x = 2
y = 1
a = 1
b = 1
AddSheetIfMissing ("Services")
Sheets("Services").Cells.Clear
Call CreateServices
Call DeleteServiceNames
For b = 1 To 39
Service = Sheets("Services").Cells(a, b).Value
For Each ws In Worksheets
If ws.Name <> "MasterMatrix" And ws.Name <> "Services" And ws.Name <> "Products" Then
Set rng = ws.Range("A9:A34")
For Each c2 In rng
If c2.Value = Service And c2.Offset(0, 1).Value = "X" Then
Sheets("Services").Cells(x, b) = ws.Name
x = x + 1
Else
End If
Next c2
Else
End If
Next ws
x = 2
y = y + 1
b = b + 1
Next b
Call MakeNamedRanges
End Sub
Function AddSheetIfMissing(Name As String) As Worksheet
'Thanks Batman! http://www.ozgrid.com/forum/showthread.php?t=53141&page=1
On Error Resume Next
Set AddSheetIfMissing = ThisWorkbook.Worksheets(Name)
If AddSheetIfMissing Is Nothing Then
Set AddSheetIfMissing = ThisWorkbook.Worksheets.Add
AddSheetIfMissing.Name = Name
End If
End Function
Sub CreateServices()
Sheets("MasterMatrix").Select
Range("A9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Services").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=True
End Sub
Sub MakeNamedRanges()
Dim rng As Range
Dim d As Integer
Dim ColCount As Integer
Dim namestr As String
Dim lastrow As Integer
Dim lastcol As Integer
Dim e As Range
Dim f As Integer
With Sheets("Services").Rows("2:2")
.Insert Shift:=xlDown
End With
lastcol = Sheets("Services").Cells(1, 255).End(xlToLeft).Column
f = 1
For Each e In Sheets("Services").Range(Cells(2, 1), Cells(2, lastcol))
e.Value = "Service" & f
f = f + 1
Next e
For d = 1 To lastcol
namestr = Sheets("Services").Cells(2, d).Value
lastrow = Sheets("Services").Cells(65000, d).End(xlUp).Row
Cells(3, d).Resize(lastrow - 1).Name = namestr
Next d
End Sub
Sub DeleteServiceNames()
'Thanks Mark O'Brian http://www.mrexcel.com/archive/VBA/31227.html
Dim nm As Name
On Error Resume Next
For Each nm In ActiveWorkbook.Names
If nm.RefersToRange.Worksheet.Name = "Services" Then
nm.Delete
End If
Next nm
End Sub
Sub ServiceValidation()
'
Dim lastrow1 As Integer
Dim rng3 As Range
On Error Resume Next
lastrow1 = Sheets("MasterMatrix").Cells(9, 1).End(xlDown).Row
Set rng3 = Sheets("MasterMatrix").Range(Cells(9, 2), Cells(lastrow1, 2))
With rng3.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=INDIRECT(""Service""&ROW()-8)"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub ProductValidation()
'
Dim lastrow1 As Integer
Dim rng4 As Range
On Error Resume Next
lastrow1 = Sheets("MasterMatrix").Cells(9, 1).End(xlDown).Row
Set rng4 = Sheets("MasterMatrix").Range(Cells(9, 4), Cells(lastrow1, 4))
With rng4.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=INDIRECT(""Product""&ROW()-8)"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Display More
