Help fixing a very ugly procedure

[Guest]

Hi;

I have written a procedure that works; but it is long, convoluted and
probably unstable i.e. ugly. I am looking for help writting a more
appropriate set of code.

Problem:

Out of a large spreadsheet I have six columns that contain jobs to be filled
by people. Each column represents a different date, so the procedure must
start over at the beginning for each date/column.

I want to use the Valitation drop down in the cells below the label for each
column.

I have a list of jobs which can vary from time-to-time on a separate
worksheet but same workbook. The list of jobs is about 10 items long.

As the user activates each cell a list of jobs that need to be done should
dropdown showing the jobs left to be fulfilled. That is, as each job is
assigned the dropdown should show the list in a particular column but with
the jobs already assigned removed. I assume that this means the pick list
(validation dropdown) has to be recalculated as to column/date and as to
which jobs are available for each column.

As I said, I have a procedure that works, but I suspect I am not making full
use of VBA and/or formulas.

Any guidance gratefully accepted.

Regards Bill

 

[Guest]

Bill,

Send us some of your code so we can know how to help.

 

[Guest]

OK Jim;

Here is the code I wrote. It is embarassing to share but done nonetheless.
Sorry it took me a day to reply.

Sub DynValidList()
' Procedure setup commands

On Error GoTo DynValidList_Error

Application.Volatile False
Worksheets("Member_List").Activate

' Declare Variables

Dim DynList() As String
Dim RowCount As Long
Dim PikCol As Long
Dim PikRow As Long
Dim NumAryItems As Long
Dim NumAryBlanks As Long

' Initiate Variables

' Read "Role_Choice" (Name range) into DynList array

NumAryItems = Range("Role_Choice").Count
ReDim DynList(NumAryItems) As String

Dim i As Long
For i = 1 To NumAryItems Step 1
DynList(i) = Range("Role_Choice").Cells(i, 1)
Next i

' Allow 7 rows for Header at start of picked items column;
' add 1 to get fist row of Picked Roles -- Fix PikRow

PikRow = Range("Col_Lables_Row").Row + 1
PikCol = 0
PikCol = ActiveCell.Column
RowCount = Range("Member_LNames").Rows.Count
NumAryBlanks = 0

' Set up array of already picked items by removing picked items
' from the DynList Array replacing items with ("") blanks.

Dim LineInDyn As Long
LineInDyn = 0
For i = 0 To RowCount Step 1
If Trim(ActiveSheet.Cells(PikRow + i, PikCol).Value) <> "" Then
LineInDyn = WorksheetFunction.Match(ActiveSheet _
.Cells(PikRow + i, PikCol).Value, Range("Role_Choice"), 0)
DynList(LineInDyn) = ""
End If
Next i

' Remove Blanks from interior of DynList Array by placing
' blanks at the end of the Array by shuffling all items upward.

Dim j As Long
Dim k As Long
For j = 1 To NumAryItems Step 1
If DynList(j) = "" Then
k = 0
Do Until j + k = NumAryItems Or DynList(j + k) <> ""
k = k + 1
Loop
DynList(j) = DynList(j + k)
DynList(j + k) = ""
End If
Next j

' Resize the DynList Array to remove blanks at the bottom.

For i = 1 To NumAryItems Step 1
If DynList(i) = "" Then _
NumAryBlanks = NumAryBlanks + 1
Next i

' Dynamically resize drop down list/Range

NumAryItems = NumAryItems - NumAryBlanks
ReDim Preserve DynList(NumAryItems)
Names.Add Name:="Flex_Role", _
RefersTo:=Range("Flex_Role").Resize(NumAryItems + 1, 1)

Range("Empty_Role").Value = _
Application.WorksheetFunction.Transpose(DynList)

' Clean up bottom of Options Offical Roles range - "Empty_Role"

For i = (NumAryItems + 2) To Range("Empty_Role").Rows.Count
If WorksheetFunction.IsNA(Range("Empty_Role").Cells(i, 1)) Then _
Range("Empty_Role").Cells(i, 1) = ""
Next i

Exit Sub

DynValidList_Error:
If Err.Number = 1004 Then
Resume Next
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure
DynValidList of Module MembInputMod"
End If

End Sub