Messy VBA code. IF AND statement not working and Userforms

secmando

New Member
Joined
Feb 9, 2017
Messages
2
Being relatively new to userforms and some VBA code I have attempted to draft a macro for a command button.
The code in essence is supposed to do the following:

1) Once you select a scheme name (one) and list of staff (one or more)y
2) You press the command button and this inserts new rows in a table and adds the scheme to column b and staff names to column e. E.g. If you select Tom, Jane and Mark working on Job A then three rows would be added and column b will say Job A for al three rows and the staff names in column e.
3) The latter formulas do a vlookup to fill in the other columns based on columns b and e
4) Finally everything gets paste values

The problem is repeating the job in column b and the error message. If you don't select a staff member than the Boolean seems to work and the error message displays. However if you do not select a scheme then it crashes.

Any suggestions on refining the code are also welcome as it has been copied from various sources.
Code:
Private Sub CommandButton3_Click()
    Dim lItem As Long, lRows As Long, lCols As Long, mItem As Long, mRows As Long
    Dim bSelected As Boolean
    Dim cSelected As Boolean
    Dim lColLoop As Long, lTransferRow As Long
    Dim intIndex As Integer
    Dim intCount As Integer
    Dim k As Integer
    Dim intRange As Range
    
    'Pass row & column count to variables
    'Less 1 as "Count" starts at zero
    lRows = ListBox1.ListCount - 1
    mRows = ListBox2.ListCount - 1
    lCols = ListBox1.ColumnCount - 1
 
 
    'Ensure they have at least 1 row selected
    For lItem = 0 To lRows
        'At least 1 row selected
        If ListBox1.Selected(lItem) = True And ListBox2.Selected(mItem) = True Then
            'Boolean flag
           bSelected = True
            'Exit for loop
           Exit For
        End If
    Next
     
    'shift cells down by number of staff memebers
    With ListBox1
        For intIndex = 0 To .ListCount - 1
            If .Selected(intIndex) Then intCount = intCount + 1
        Next
    End With
    
    Set intRange = Range("8:8")
    rng = intCount
    For k = 1 To rng
        Rows(intRange.Row).Insert Shift:=xlDown, _
              CopyOrigin:=xlFormatFromRightOrBelow
    Next
     
          
    'At least 1 row selected
    If bSelected = True Then
        With Sheet9.Range("e8", Sheet9.Cells(lRows + 1, 5 + lCols)) 'Transfer to range
                For lItem = 0 To lRows
                If ListBox1.Selected(lItem) = True Then 'Row selected
                  'Increment variable for row transfer range
                  lTransferRow = lTransferRow + 1
                    'Loop through columns of selected row
                    For lColLoop = 0 To lCols
                       'Transfer selected row to relevant row of transfer range
                       .Cells(lTransferRow, lColLoop + 1) = ListBox1.List(lItem, lColLoop)
                        'Uncheck selected row
                        ListBox1.Selected(lItem) = False
                    Next lColLoop
                End If
            Next
       End With

     Unload Me
     Else ' NO listbox row chosen
       MsgBox "No staff have been selected", vbCritical
    End If
   
'Section to then use outputs from listbox and use vlookup to apply staff information
Dim StaffLastRow As Long
Dim ProjectLastRow As Long
Dim OutputLastRow As Long
Dim StaffSheet As Worksheet
Dim Projectsheet As Worksheet
Dim OutputSheet As Worksheet
'What are the names of our worksheets?
Set StaffSheet = Worksheets("Staff data")
Set Projectsheet = Worksheets("Project list")
Set OutputSheet = Worksheets("Sheet2")
'Determine last row of staff list
With StaffSheet
     StaffLastRow = .Cells(.Rows.Count, "b").End(xlUp).Row
End With
With OutputSheet
     'Determine last row in col E
    OutputLastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
     'Apply our formula
    .Range("f8:f" & OutputLastRow).Formula = _
         "=VLOOKUP(e8,'" & StaffSheet.Name & "'!$b$2:$e$" & StaffLastRow & ",3,0)"
         
    .Range("g8:g" & OutputLastRow).Formula = _
         "=VLOOKUP(e8,'" & StaffSheet.Name & "'!$b$2:$e$" & StaffLastRow & ",2,0)"
                  
    .Range("h8:h" & OutputLastRow).Formula = _
         "=VLOOKUP(e8,'" & StaffSheet.Name & "'!$b$2:$e$" & StaffLastRow & ",4,0)"
  
End With
'Determine last row of project list
With Projectsheet
     ProjectLastRow = .Cells(.Rows.Count, "b").End(xlUp).Row
End With
With OutputSheet
     'Determine last row in col E
    OutputLastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
     'Apply our formula
    .Range("c8:c" & OutputLastRow).Formula = _
         "=VLOOKUP(b8,'" & Projectsheet.Name & "'!$a$2:$c$" & ProjectLastRow & ",2,0)"
         
    .Range("d8:d" & OutputLastRow).Formula = _
         "=VLOOKUP(b8,'" & Projectsheet.Name & "'!$a$2:$c$" & ProjectLastRow & ",3,0)"
       
End With
 ' Project Insert
    Dim listItems As String, i As Long
       
    With ListBox2
       For i = 0 To .ListCount - 1
       If .Selected(i) Then listItems = listItems & .List(i) & ", "
    Next i
    End With
    
    Range("b8:b" & 7 + rng) = Left(listItems, Len(listItems) - 2)
'Turn all formulas into values
    OutputSheet.UsedRange.Value = OutputSheet.UsedRange.Value
    

    
End Sub
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Changing the If to

Code:
If ListBox1.Selected(lItem) = True Or ListBox2.Selected(mItem) = True Then

Has helped but it still breaks if I don't selected anything in Listbox2
 
Upvote 0

Forum statistics

Threads
1,214,935
Messages
6,122,337
Members
449,078
Latest member
skydd

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top