Private Sub CmdSelect2_Click()
Dim intSh As Integer
Dim Msg As String
Dim wks As Worksheet
Dim strLC As String
Dim Rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim i As Integer
Dim r As Object, LR As Long
Dim TBName As String
Dim WBName As String
Dim strPfad As String
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set wks = Worksheets.Add
wks.Name = "Completed Checklist"
If Me.ListBox2.ListCount = 0 Then Exit Sub
For intSh = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(intSh) Then Msg = Msg & Me.ListBox2.List(intSh) & vbCr
Next
Unload Me
For i = 3 To wb.Worksheets.Count
If InStr(Msg, wb.Sheets(i).Name) > 0 Then
With wb.Sheets(i).UsedRange
LR = wks.Cells(Rows.Count, "A").End(xlUp).Row + 1
strLC = .Cells(.Rows.Count, .Columns.Count).Address
Set Rng = .Range("A1:" & strLC)
Rng.Copy Destination:=wks.Cells(LR, 1)
End With
End If
Next i
wks.Select
Columns("A:A").WrapText = False
Columns("A:A").ColumnWidth = 8
Columns("A:A").Rows.AutoFit
Columns("B:B").WrapText = False
Columns("B:B").ColumnWidth = 10
Columns("B:B").Rows.AutoFit
Columns("C:C").WrapText = True
Columns("C:C").ColumnWidth = 74
Columns("C:C").Rows.AutoFit
Columns("D:D").WrapText = True
Columns("D:D").ColumnWidth = 8
Columns("D:D").Rows.AutoFit
Columns("E:E").WrapText = True
Columns("E:E").ColumnWidth = 8
Columns("E:E").Rows.AutoFit
Columns("F:F").WrapText = True
Columns("F:F").ColumnWidth = 8
Columns("F:F").Rows.AutoFit
Columns("G:G").WrapText = True
Columns("G:G").ColumnWidth = 34
Columns("G:G").Rows.AutoFit
For Each r In ActiveSheet.UsedRange.Rows
r.EntireRow.AutoFit
If r.RowHeight < 25 Then r.RowHeight = 25
Next
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.Zoom = 85
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
TBName = ActiveSheet.Name
WBName = InputBox("Under which name would you like to " & _
"save your checklist?" & vbLf & vbLf & _
"Please enter filename:")
If WBName = "" Then
Application.DisplayAlerts = False
Worksheets(TBName).Delete
Application.DisplayAlerts = True
Exit Sub
End If
Worksheets(TBName).Move
strPfad = Environ("UserProfile") & "\Desktop\"
ActiveWorkbook.SaveAs Filename:=strPfad & WBName, FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
ActiveWorkbook.Close
MsgBox "Your Checklist has been saved on your Desktop!"
Exit Sub
ErrorMessage:
MsgBox "An Error Occurred!"
Application.ScreenUpdating = True
End Sub