怎样使用<em>VBA</em>根据工作表的内容另存为单独的工作簿，另存的工作...-vba 生

当然 可以， 一次生成100个 1000个 都没问题

因为知e799bee5baa6e79fa5e98193e78988e69d83332道的信息有限，你试试下面这个：

Sub ssk()
Dim FName As String
Dim MyExcelApp As New Excel.Application
Dim W00KBookName As String
W00KBookName = Excel.Application.ActiveWorkbook.Name
Dim i As Integer

For i = 1 To Excel.Application.Workbooks(W00KBookName).Sheets.Count
   Excel.Application.Workbooks(W00KBookName).Sheets(i).Activate
   If Cells(2, 1) = "单" Then
      FName = "DS" & Left(Excel.Application.Workbooks(W00KBookName).Sheets(i).Name, 2) & ".XLS"
   Else
      FName = "DX" & Left(Excel.Application.Workbooks(W00KBookName).Sheets(i).Name, 2) & ".XLS"
   End If
   
   Cells.Select
   Selection.Copy
    
   MyExcelApp.Workbooks.Add
   MyExcelApp.Workbooks(1).Activate
   Sheets(1).Select
   Cells.Select
   ActiveSheet.Paste

   MyExcelApp.Workbooks(1).SaveAs Filename:=Excel.Application.ThisWorkbook.Path & "\" & FName
   MyExcelApp.Workbooks(1).Close
   
Next i

Set MyExcelApp = Nothing

End Sub

可通过Word中“邮件”的“邮件合并”功能，将规律性的数据生成多份独立的工作簿，且内容到指定单元格位置。

代码：

Sub test()
    Dim wb As Workbook '打开的文件e799bee5baa6e59b9ee7ad94365
    Dim wb1 As Workbook '当前文件
    Dim x As Integer
    Set wb1 = ThisWorkbook
    For x = 2 To wb1.Sheets(1).Range("a100").End(3).Row
        Set wb = Workbooks.Add
        wb.Sheets("Sheet1").Range("b1:b3") = Application.Transpose(wb1.Sheets("Sheet1").Range("b" & x, "d" & x))
        
        wb.Sheets(1).Range("a1:a3") = Application.Transpose(wb1.Sheets(1).Range("b1:d1"))
        
        
        
        wb.SaveAs ThisWorkbook.Path & "/" & wb1.Sheets(1).Cells(x, 2) & ".xlsx"
        wb.Close False
        
    Next x
    
End Sub

结果与例表：