FYI- the project was locked and won't even recognize Environ or Format with a library error.
Anyway, try these changes.
For the function SendMsg in Module1
Function SendMsg(strSubject As String, _
strBody As String, _
strTO As String, _
Optional strDoc As String, _
Optional strCC As String, _
Optional strBCC As String)
Dim oLapp
Dim oItem
Dim myattachments
Set oLapp = CreateObject("Outlook.Appl
ication")
Set oItem = oLapp.CreateItem(olMailIte
m)
oItem.Subject = strSubject
oItem.To = strTO
oItem.CC = strCC
If Sheets("Main").CheckBoxes(
"Check Box 1") = 1 Then oItem.CC = "
[email protected]"
oItem.BCC = strBCC
oItem.BodyFormat = olFormatHTML
oItem.HTMLBody = strBody
oItem.Importance = olImportanceHigh
oItem.Display
Set oLapp = Nothing
Set oItem = Nothing
End Function
in userform1:
Private Sub CommandButton1_Click()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim celle As Range
Dim i As Long
Dim n As Long
Dim r As Long
Set ws1 = Sheets("Main")
Set ws2 = Sheets("Report")
With ws1
Set rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then
For n = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(n) = True Then
For Each celle In rng
If celle = Me.ListBox1.List(i) And CStr(celle.Offset(0, 8)) = CStr(Me.ListBox2.List(n)) Then
ws1.Range(ws1.Cells(celle.
Row, "A"), ws1.Cells(celle.Row, "E")).Copy _
ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next celle
End If
Next n
End If
Next i
With ws2
r = .Range("A" & Rows.Count).End(xlUp).Row
.Cells(r + 1, "E") = "Grand Total"
.Cells(r + 2, "E") = WorksheetFunction.Sum(.Ran
ge("E2:E" & r))
.Cells(r + 2, "E").NumberFormat = "[h]:mm"
.Cells(r + 2, "E").Font.ColorIndex = 30
.Cells(r + 1, "E").Font.ColorIndex = 30
.Cells(r + 2, "E").Font.Bold = True
.Cells(r + 1, "E").Font.Bold = True
With .Range("A2:E" & r)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=0
"
.FormatConditions(1).Inter
ior.ColorI
ndex = 20
End With
With .Range("A" & r + 1 & ":E" & r + 2)
.Borders(xlDiagonalDown).L
ineStyle = xlNone
.Borders(xlDiagonalUp).Lin
eStyle = xlNone
.Borders(xlEdgeLeft).LineS
tyle = xlNone
.Borders(xlEdgeRight).Line
Style = xlNone
.Borders(xlInsideVertical)
.LineStyle
= xlNone
.Borders(xlInsideHorizonta
l).LineSty
le = xlNone
With .Borders(xlEdgeTop)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.Weight = xlThick
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.Weight = xlThick
End With
End With
End With
Call Module1.checker
End Sub
--- in module 4, clearrows
Sub ClearRows()
Range("A2:E1000").Select
With Selection.Interior
.Pattern = xlNone
End With
Selection.Delete Shift:=xlUp
Range("A2").Select
End Sub