リストボックス内のシートのみをエクスポートする

Question

UserformにはListboxとエクスポートボタンがあります。リストボックスには、ブック内のすべてのシート名が一覧表示されます。リストボックスでシート名を選択してエクスポートをクリックして、貼り付けのみの値&（元のシートのフォーミュラとフォームボタンなし）を作成するコピーをデスクトップに作成したいと考えています。

リストボックスにシート名を表示するのに成功しましたが、エクスポートボタンのコードに問題がありますが、範囲外のエラーが発生します。

以上続いたり、コメント

Private Sub CommandButton1_Click() 

Dim lSht As Long 
Dim wb As Workbook 
Dim sPath As String 
Dim sSheet As String 
Dim NewWbName As String 
Dim i As Long 

'Set variables 
Set wb = Workbooks.Add 

'Add a filepath to your computer below 
sPath = "C:\Users\" & Environ("USERNAME") & "\Desktop\" 
NewWbName = "Reports " & Format(Now, "yyyy_mm_dd _hh_mm") 
i = 1 

'Loop through listbox 
For lSht = 0 To Me.sheetlist.ListCount - 1 

    'check if items selected 
    If Me.sheetlist.Selected(lSht) = True Then 
     'copy out the sheet and saveas 
     sSheet = Me.sheetlist.List(lSht) 

     With wb.Worksheets(sSheet).Copy 
      .PasteSpecial (xlPasteValues) 
      .PasteSpecial (xlPasteFormats) 
     End With 

     Application.DisplayAlerts = False 

     wb.SaveAs Filename:=DesktopPath & NewWbName, FileFormat:=xlNormal 
     wb.Close 
     MsgBox "You can find the export file in your desktop.", vbOKOnly + vbInformation, "Back Up Sucessful!" 

     Application.DisplayAlerts = True 
    End If 
Next lSht 

End Sub 

Answer 1

、以下のコードを試してみてください。

Private Sub CommandButton1_Click() 

Dim wb    As Workbook 
Dim newWb   As Workbook 
Dim sPath   As String 
Dim sSheet   As String 
Dim NewWbName  As String 
Dim lSht   As Long 
Dim NewSht   As Worksheet 
Dim i    As Long 
Dim firstExport  As Boolean 

'Set variables 
Set wb = ThisWorkbook 
Set newWb = Workbooks.Add 

Application.DisplayAlerts = False 
firstExport = True 

'Add a filepath to your computer below 
sPath = "C:\Users\" & Environ("USERNAME") & "\Desktop\" 
NewWbName = "Reports " & Format(Now, "yyyy_mm_dd _hh_mm") 

'Loop through listbox 
For lSht = 0 To Me.sheetlist.ListCount - 1 

    'check if items selected 
    If Me.sheetlist.Selected(lSht) = True Then 
     'copy out the sheet and saveas 
     sSheet = Me.sheetlist.List(lSht) 

     If firstExport Then 
      firstExport = False 

      ' remove all sheets (exceot 1) in first Copy>Paste 
      For i = newWb.Sheets.Count - 1 To 1 Step -1 
       newWb.Sheets(i).Delete 
      Next i 

      ' add new sheet to new workbook and put it at theend 
      Set NewSht = newWb.Sheets(newWb.Sheets.Count) 
     Else 
      ' add new sheet to new workbook and put it at the end 
      Set NewSht = newWb.Sheets.Add(After:=newWb.Sheets(newWb.Sheets.Count)) 
     End If 

     NewSht.Name = sSheet 
     With wb.Sheets(sSheet) 
      .Cells.Copy 
      NewSht.Cells.PasteSpecial (xlPasteValues) 
      NewSht.Cells.PasteSpecial (xlPasteFormats) 
     End With 

    End If 
Next lSht 

' need to move the save workbook outside the Copy all selected sheets "loop" 
newWb.SaveAs Filename:=sPath & NewWbName, FileFormat:=xlNormal 
newWb.Close True 
MsgBox "You can find the export file in your desktop.", vbOKOnly + vbInformation, "Back Up Sucessful!" 

Application.DisplayAlerts = True 

End Sub