仅导出列表框中的工作表

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