excel - 在每个工作表中复制粘贴特定范围并将该范围粘贴到单独的工作簿中以保存在单个文件夹中

Question

1. 此代码用于将工作表中的所有数据复制到单独的工作簿中，我只想将每个工作表中的特定区域复制到单独的工作簿中。

2. 在IF语句之前，我在xWs.Copy下面放了如下语句，我指定范围为xWs.Range("E2:G15").Copy，代码不起作用。请帮助我解决或给我任何提示。我是 VBA 新手。非常感谢您

   Sub SplitWorkbook()
   
   Dim FileExtStr As String 
   Dim FileFormatNum As Long 
   Dim xWs As Worksheet 
   Dim xWb As Workbook 
   Dim FolderName As String
   
   Application.ScreenUpdating = False
   Set xWb = Application.ThisWorkbook
   DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
   FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
   MkDir FolderName
   
       For Each xWs In xWb.Worksheets
          xWs.Copy
        If Val(Application.Version) < 12 Then
           FileExtStr = ".xls": FileFormatNum = -4143
               Else
               Select Case xWb.FileFormat
               Case 51:
                 FileExtStr = ".xlsx": FileFormatNum = 51
               Case 52:
                 If Application.ActiveWorkbook.HasVBProject Then
                 FileExtStr = ".xlsm": FileFormatNum = 52
               Else
                 FileExtStr = ".xlsx": FileFormatNum = 51
               End If
           Case 56:
               FileExtStr = ".xls": FileFormatNum = 56
           Case Else:
               FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
     End If
      xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
       Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
      Application.ActiveWorkbook.Close False
   Next
   MsgBox "You can find the files in " & FolderName
   Application.ScreenUpdating = True
   End Sub
   

标签： excelvba

Answer 1

每次循环浏览工作表时，您可以添加一个工作簿，然后将范围复制并粘贴到新工作簿中。保存并关闭新工作簿。

此示例显示了如何执行此操作。

我没有弄乱您代码的保存部分，我认为这对您有用。

Sub Button2_Click()
    Dim wb As Workbook, bk As Workbook
    Dim sh As Worksheet

    Set wb = ThisWorkbook

    For Each sh In Sheets
        With sh
            Set bk = Workbooks.Add(xlWBATWorksheet)
            .Range("E2:G15").Copy bk.Sheets(1).Range("A1")
            bk.SaveAs "C:\Users\Dave\AppData\Local\Temp\" & sh.Name & ".xlsx"
            bk.Close
        End With
    Next sh

End Sub