Select worksheets via listbox and merge into new workbook

[cille40]

Dear Community,

I'm new to this forum and I hope you can help an excel VBA newbie with the following problem:

In Excel 2010 a listbox is activated via Command Button which enables the selection of the worksheets by worksheet name (except the first sheet). Then, the selected sheets should be copied and merged into a new workbook which should automatically be saved under a specified path.
The file contains items from a checklist which can be compiled together depending on the subject to be checked. Those items are contained in the concerned worksheets.

So far my marcro looks like this:

Option Explicit

Private Sub CmdCancel2_Click()
Unload Me
End Sub

Private Sub CmdSelect2_Click()

Dim intSh As Integer
Dim Msg As String
Dim wks As Worksheet
Dim strLC As String
Dim Range As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim i As Integer
Dim r As Object

Application.ScreenUpdating = False

Set wks = Worksheets.Add
wks.Name = "Completed Checklist"

On Error Resume Next

For Each ws In wb.Worksheets
If Me.ListBox2.ListCount > 0 Then
For intSh = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(intSh) Then
Sheets(intSh + 1).Copy
Msg = Msg & Me.ListBox2.List(intSh) & vbCr
Unload Me
End If
Next
End If

For i = 2 To Worksheets.Count
With Sheets(i).UsedRange
strLC = .Cells(.Rows.Count, .Columns.Count).Address
Set Range = .Range("A1:" & strLC)
Range.Copy Destination:= _
wks.Cells(Rows.Count, 1).End(xlUp)
Columns("A:A").WrapText = False
Columns("A:A").ColumnWidth = 8
Columns("A:A").Rows.AutoFit
Columns("B:B").WrapText = True
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
End With
Msg = Msg & Me.ListBox2.List(intSh) & vbCr
Unload Me

Next i

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

Application.ScreenUpdating = True


MsgBox "The following paragraphs have been listed in your checklist: " & vbCr & vbCr & Msg
Next

End Sub

Private Sub Label1_Click()

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
Dim intI As Integer

For intI = 2 To Worksheets.Count
Me.ListBox2.AddItem Worksheets(intI).Name
Next
End Sub

Unfortunately, the only thing which happens so far is that a new but empty sheet with the name "Completed Checklist" is opened within the existing workbook and a new workbook is being generated with the first sheet copied from the original book.

I really hope you can help me with this.

Thank you very much in advance!

Greetings from Switzerland

Cille

[patel]

attach please a sample xlsm file

[cille40]

Hi Patel,

here is the file:

Excercise 9.xls

[patel]

Private Sub CmdSelect2_Click()
.........  

Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set wks = Worksheets.Add
wks.Name = "Completed Checklist"
If Me.ListBox2.ListCount > 0 Then
   For intSh = 0 To Me.ListBox2.ListCount - 1
    If Me.ListBox2.Selected(intSh) Then
     wb.Sheets(intSh + 3).Copy
     Msg = Msg & Me.ListBox2.List(intSh) & vbCr
     Unload Me
     End If
     Next

[cille40]

Hi Patel,

Thank you very much for your help!

Unfortunately the macro now opens two seperate new books and does not merge the selected sheets into one sheet.

Do you have any advise for this please?

[patel]

Your code opens many workbooks, not only one, your goal is not very clear for me

[cille40]

Well the ultimate goal would be to have all selected worksheets from the current workbook merged in one single worksheet in a new book.
So all the checklist items should be listed continuousely under each other.

I hope its more clear now.

Thank you once again for your patience!

[patel]

try this code, if good you can copy the first sheet and save it

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

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 = True
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
Application.ScreenUpdating = True
MsgBox "The following paragraphs have been listed in your checklist: " & vbCr & vbCr & Msg
End Sub

[cille40]

Hi Patel,

Works great!

Thank you very much!

I will be able to figure out the last steps myself.

Thank you once again!