Results 1 to 9 of 9

Thread: Select worksheets via listbox and merge into new workbook

  1. #1

    Select worksheets via listbox and merge into new workbook



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

  2. #2
    Acolyte patel's Avatar
    Join Date
    Feb 2014
    Location
    Italy
    Posts
    59
    Articles
    0
    attach please a sample xlsm file

  3. #3
    Hi Patel,

    here is the file:

    Excercise 9.xls

  4. #4
    Acolyte patel's Avatar
    Join Date
    Feb 2014
    Location
    Italy
    Posts
    59
    Articles
    0
    Code:
    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

  5. #5
    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?

  6. #6
    Acolyte patel's Avatar
    Join Date
    Feb 2014
    Location
    Italy
    Posts
    59
    Articles
    0
    Your code opens many workbooks, not only one, your goal is not very clear for me

  7. #7
    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!

  8. #8
    Acolyte patel's Avatar
    Join Date
    Feb 2014
    Location
    Italy
    Posts
    59
    Articles
    0
    try this code, if good you can copy the first sheet and save it
    Code:
    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

  9. #9
    Hi Patel,

    Works great!

    Thank you very much!

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

    Thank you once again!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •