使用對話框進行工作表選擇並將其作爲值複製到新工作簿中

我想編寫代碼，允許用戶在打開的工作簿中選擇多個工作表並將其作爲值複製到另一個工作簿中，該工作簿保存在與原始位置相同的位置（使用者未指定其他名稱）。（我是VBA的一個相對較新的用戶，但之前有過編程經驗）。使用對話框進行工作表選擇並將其作爲值複製到新工作簿中

我已經成功地編寫了一些代碼，這些代碼會根據工作簿中的工作表生成一個填充了複選框的對話框，並創建一個新文件並將其保存在適當的位置。

但是，我在遍歷所選工作表時遇到了問題，並將它們作爲值複製並粘貼到新書中。當我打開新創建的工作簿時，它是空的。所以似乎複製/粘貼沒有奏效。

該代碼最初是基於我在網上找到的代碼來選擇任何表並打印它們。任何洞察下面的代碼將不勝感激。（我包括額外的代碼，以防萬一在那裏有一些潛在的問題，阻止後來的代碼工作）。

Sub CreateCirculationCopy() 

    Dim CurrentSheet As Worksheet 
    Dim wb As Workbook 
    Dim ws As Worksheet 
    Dim i As Integer 
    Dim TopPos As Integer 
    Dim SheetCount As Integer 
    Dim SelectDlg As DialogSheet 
    Dim cb As CheckBox 
    Dim Current As String 
    Dim x As Integer 

    Application.ScreenUpdating = False 

    'Add a temp dialog sheet 
    Set CurrentSheet = ActiveSheet 
    Set SelectDlg = ActiveWorkbook.DialogSheets.Add 

    SheetCount = 0 

    'Add the checkboxes 
    TopPos = 40 
    For i = 1 To ActiveWorkbook.Worksheets.Count 
     Set CurrentSheet = ActiveWorkbook.Worksheets(i) 
     'Skip empty and hidden sheets 
     If CurrentSheet.Visible Then 
      SheetCount = SheetCount + 1 
      SelectDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 
       SelectDlg.CheckBoxes(SheetCount).Text = _ 
       CurrentSheet.Name 
      TopPos = TopPos + 13 
     End If 
    Next i 

    'Format dialog box 
    SelectDlg.Buttons.Left = 240 
    With SelectDlg.DialogFrame 
     .Height = Application.Max _ 
      (68, SelectDlg.DialogFrame.Top + TopPos - 34) 
     .Width = 230 
     .Caption = "Select sheets to copy" 
    End With 
    SelectDlg.Buttons("Button 2").BringToFront 
    SelectDlg.Buttons("Button 3").BringToFront 

    'Display the dlg box 
    Set wb = Workbooks.Add 
    x = 1 
    Application.DisplayAlerts = False 
    CurrentSheet.Activate 
    Application.ScreenUpdating = True 
    If SheetCount <> 0 Then 
     If SelectDlg.Show Then 
      For Each cb In SelectDlg.CheckBoxes 
       If cb.Value = x10n Then 
       Worksheets(cb.Caption).Activate 
       ActiveSheet.Cells.Copy 
       'ActiveSheet.UsedRange.Copy 
       Windows(wb).Activate 
       wb.Sheets("Sheet" & x).Activate 
       ActiveSheet.Cells("A1").PasteSpecial xlPasteValues, _ 
         Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
       Workbooks(1).Activate 
       Worksheets(cb.Caption).Activate 
       x = x + 1 
       End If 
      Next cb 
     End If 
    Else 
     MsgBox "All worksheets are empty" 
    End If 

    Filename = ThisWorkbook.Path & "\" & "Circulation.xlsx" 
    wb.SaveAs Filename, XlFileFormat.xlOpenXMLWorkbook 
    wb.Close 

    SelectDlg.Delete 
    Application.DisplayAlerts = True 
    CurrentSheet.Activate 


End Sub

來源

2015-05-25 sbolger

使用DialogSheet很有趣，但簡單的方法是創建用戶窗體與列表框，讓用戶多選ListBox1.MultiSelect = fmMultiSelectMulti。

但是，這並不重要:)

使用你的，我有一個問題，If cb.Value = x10n Then，x10n等於Empty。

問題二Windows(wb).Activate，wb它是一個對象，我用Windows(wb.Name).Activate

我有複製一個問題：我將其更改爲Selection.PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

部分稍作修改的代碼ActiveSheet.Cells("A1").PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

：

If SelectDlg.Show Then 
     For Each cb In SelectDlg.CheckBoxes 
      If cb.Value = 1 Then 
      Worksheets(cb.Caption).Activate 
      ActiveSheet.Cells.Copy 
      Windows(wb.Name).Activate 
      wb.Sheets("S" & x).Activate 
      Selection.PasteSpecial xlPasteValues, _ 
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
      Workbooks(1).Activate 
      Worksheets(cb.Caption).Activate 
      x = x + 1 
      End If 
     Next cb 
    End If

讓我知道如果它工作

來源

2015-05-25 09:02:59 Dawid

嗨Dawid，我嘗試使用一個用戶窗體，但我發現該對話框更容易與動態信息生成。這些變化的幫助，非常感謝。只需要更多一點的代碼，直到我得到我想要的結果。我完成後會發布代碼。 – sbolger

使用對話框進行工作表選擇並將其作爲值複製到新工作簿中

回答

相關問題