Re-asking about "ugly" procedure ??

[Guest]

Hi;

A week ago I posted here asking for some help. I received a response asking
for me post the actual code I ha written. I did but got no further response,
so I am taking the liberty of asking again.

"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."

And further;

"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"

Regards Bill

 

[Guest]

Bill, I don't see anything terribly wrong with the code. I would move all of
my Dim statements to the beginning of the procedure just to make the
executable portion easier to read. If it ain't broke, don't fix it. Since I
cannot see how you have your columns, rows and other ranges named, I have to
assume that where you use them they are working properly, because you said
the code worked. Don't worry about how it looks at this point. The more you
work with code, the more you will learn about how to make it more efficient
and look pretty at the same time.

 

[Bob Phillips]

Bill,

You probably didn't get a reply as it took you a day to respond. The
turnover of threads is very high in these groups.

Anyway, to the code.

The biggest thing I would do is to break it up into many procedures, to aid
maintenance.

There is also no need to load a variable with 0 then a proper value


PikCol = 0
PikCol = ActiveCell.Column


Here is my amended code, I just compiled it error-free, I didn't test it.

Sub DynValidList()
Dim DynList() As String
Dim RowCount As Long
Dim PikCol As Long, PikRow As Long
Dim NumAryItems As Long, NumAryBlanks As Long
' Procedure setup commands

On Error GoTo DynValidList_Error

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

Call Initialize(DynList, RowCount, PikRow, PikCol, NumAryBlanks,
NumAryItems)

Call SetupArray(DynList, RowCount, PikRow, PikCol, NumAryBlanks,
NumAryItems)

Call SetupDV(DynList, NumAryBlanks, NumAryItems)

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

Private Sub Initialize(ByRef pzDynList, ByRef pzRowCount As Long, _
ByRef pzPikRow As Long, ByRef pzPikCol As Long, _
ByRef pzNumAryBlanks As Long, ByRef pzNumAryItems As
Long)
' Initiate Variables
Dim i As Long

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

pzNumAryItems = Range("Role_Choice").Count
ReDim pzDynList(pzNumAryItems) As String

For i = 1 To pzNumAryItems Step 1
pzDynList(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

pzPikRow = Range("Col_Lables_Row").Row + 1
pzPikCol = ActiveCell.Column
pzRowCount = Range("Member_LNames").Rows.Count
pzNumAryBlanks = 0
End Sub

Private Sub SetupArray(ByRef pzDynList, ByVal pzRowCount As Long, _
ByVal pzPikRow As Long, ByVal pzPikCol As Long, _
ByVal pzNumAryBlanks As Long, ByVal pzNumAryItems As
Long)
Dim i As Long, j As Long, k As Long
Dim LineInDyn As Long

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

LineInDyn = 0
For i = 0 To pzRowCount Step 1
If Trim(ActiveSheet.Cells(pzPikRow + i, pzPikCol).Value) <> "" Then
LineInDyn = WorksheetFunction.Match(ActiveSheet _
.Cells(pzPikRow + i, pzPikCol).Value, Range("Role_Choice"), 0)
pzDynList(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.

For j = 1 To pzNumAryItems Step 1
If pzDynList(j) = "" Then
k = 0
Do Until j + k = pzNumAryItems Or pzDynList(j + k) <> ""
k = k + 1
Loop
pzDynList(j) = pzDynList(j + k)
pzDynList(j + k) = ""
End If
Next j

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

For i = 1 To pzNumAryItems Step 1
If pzDynList(i) = "" Then _
pzNumAryBlanks = pzNumAryBlanks + 1
Next i

End Sub

Private Sub SetupDV(ByRef pzDynList, _
ByRef pzNumAryBlanks As Long, ByRef pzNumAryItems As
Long)
Dim i As Long

' Dynamically resize drop down list/Range

pzNumAryItems = pzNumAryItems - pzNumAryBlanks
ReDim Preserve pzDynList(pzNumAryItems)
Names.Add Name:="Flex_Role", _
RefersTo:=Range("Flex_Role").Resize(pzNumAryItems + 1, 1)

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

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

For i = (pzNumAryItems + 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

End Sub



--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

 

[Guest]

:
Thanks JLGWhiz and Bob Phillips;

Just rating your suggestions seemed inadequate. So accept my personal
thanks for your time and effort. I am definetly useing your corrections.

The comments you gave me were reassuring.

Hi;

A week ago I posted here asking for some help. I received a response asking
for me post the actual code I ha written. I did but got no further response,
so I am taking the liberty of asking again.

Regards Bill