attach please a sample xlsm file
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
attach please a sample xlsm file
Hi Patel,
here is the file:
Excercise 9.xls
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
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?
Your code opens many workbooks, not only one, your goal is not very clear for me
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!
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
Hi Patel,
Works great!
Thank you very much!
I will be able to figure out the last steps myself.
Thank you once again!
Bookmarks