excel vba代码,实现将工作簿中的工作表拆分成工作簿,不保留原格式,只有值
时间: 2023-07-31 22:09:45 浏览: 82
以下是一个简单的 Excel VBA 代码示例,可以将当前工作簿中的每个工作表分别保存为一个新工作簿,并只保留值(不保留原格式)。
```vb
Sub SplitWorksheetsToWorkbooks()
Dim wb As Workbook
Dim newWb As Workbook
Dim ws As Worksheet
Dim savePath As String
Set wb = ActiveWorkbook
savePath = wb.Path & "\" ' 在同一目录下保存
For Each ws In wb.Worksheets
Set newWb = Workbooks.Add ' 创建新工作簿
ws.Copy ' 将当前工作表复制到新的工作簿中
With newWb
.SaveAs Filename:=savePath & ws.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook ' 以当前工作表命名并保存
.Close False ' 关闭工作簿而不保存更改,以便进行下一个迭代
End With
Next ws
End Sub
```
请注意,此代码将使用默认的 Excel 文件格式 `.xlsx` 保存新工作簿。如果需要使用其他文件格式,请相应地更改 `FileFormat` 参数。
相关问题
Excel拆分成多个工作簿vba代码
以下是一个示例的VBA代码,用于将Excel工作簿拆分成多个工作簿:
```vba
Sub SplitWorkbook()
Dim OriginalWorkbook As Workbook
Dim NewWorkbook As Workbook
Dim OriginalWorksheet As Worksheet
Dim NewWorksheet As Worksheet
Dim Cell As Range
Dim RowCounter As Long
Dim LastRow As Long
Dim SplitColumn As Range
Dim UniqueValues As Collection
Dim Value As Variant
' 设置原始工作簿和工作表
Set OriginalWorkbook = ThisWorkbook
Set OriginalWorksheet = OriginalWorkbook.Worksheets("Sheet1") ' 替换为您要拆分的工作表名称
' 设置拆分列范围
Set SplitColumn = OriginalWorksheet.Range("A:A") ' 替换为您要拆分的列
' 获取唯一值集合
Set UniqueValues = New Collection
On Error Resume Next
For Each Cell In SplitColumn
UniqueValues.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
' 遍历唯一值并创建新工作簿
For Each Value In UniqueValues
' 创建新工作簿并复制原始工作表的结构和数据
Set NewWorkbook = Workbooks.Add
Set NewWorksheet = NewWorkbook.Worksheets(1)
OriginalWorksheet.Copy Before:=NewWorksheet
' 删除除唯一值之外的行
With NewWorksheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For RowCounter = LastRow To 2 Step -1 ' 从最后一行开始往上遍历
If .Cells(RowCounter, 1).Value <> Value Then
.Rows(RowCounter).Delete
End If
Next RowCounter
End With
' 保存新工作簿
NewWorkbook.SaveAs "路径\" & Value & ".xlsx" ' 替换为您要保存的路径和文件名
' 关闭新工作簿
NewWorkbook.Close SaveChanges:=False
Next Value
End Sub
```
请注意,您需要根据实际情况进行以下修改:
1. 将`"Sheet1"`替换为您要拆分的工作表名称。
2. 将`"A:A"`替换为您要拆分的列范围。
3. 将`"路径\" & Value & ".xlsx"`替换为您要保存的路径和文件名。
运行此代码后,它将根据指定的列中的唯一值,将原始工作簿拆分为多个新的工作簿,并将每个唯一值命名为文件名。每个新工作簿将只包含与对应唯一值匹配的行。
批量Excel 多个工作簿合并、拆分分成多个工作表vba代码
以下是一个将多个工作簿合并到一个工作表的VBA代码:
```
Sub MergeWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
' Change this to the path\folder location of your files.
MyPath = "C:\MyDocuments\"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' Set the file filter to find Excel files.
FilesInPath = "*.xlsx*"
' Set the first result file number to 0.
FNum = 0
' Loop through all files in the folder.
If Dir(MyPath & FilesInPath) = "" Then
MsgBox "No files found."
Exit Sub
End If
' Turn off calculation and screen updating.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Set the base worksheet for the merge.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' Loop through all files.
Do While Dir(MyPath & FilesInPath) <> ""
' Add to the file count.
FNum = FNum + 1
' Re-dimension the array to hold the new file name.
ReDim Preserve MyFiles(1 To FNum)
' Store the file name.
MyFiles(FNum) = Dir(MyPath & FilesInPath)
' Go to the next file name.
DirCount = DirCount + 1
Dir
Loop
' Set the starting row for the copy.
rnum = 1
' Loop through all files and worksheets, copying the data to the base worksheet.
For FNum = 1 To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
For Each sourceSheet In mybook.Worksheets
' Find the last row of data on the source worksheet.
SourceRcount = sourceSheet.Cells(Rows.Count, "A").End(xlUp).Row
' Set the source range.
Set sourceRange = sourceSheet.Range("A1:Z" & SourceRcount)
' Copy the data to the base worksheet.
Set destrange = BaseWks.Range("A" & rnum)
sourceRange.Copy destrange
' Increase the row counter.
rnum = rnum + SourceRcount
Next sourceSheet
mybook.Close savechanges:=False
Next FNum
' Turn on calculation and screen updating.
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
' Auto-fit the columns on the base worksheet.
BaseWks.Columns.AutoFit
End Sub
```
以下是将工作表拆分为多个工作簿的VBA代码:
```
Sub SplitWorkbook()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Dim Lrow As Long
Dim OutFolder As String
' Change this to the path\folder location where you want to save the new files.
OutFolder = "C:\MyDocuments\"
' Create a new folder for the output files.
If Len(Dir(OutFolder, vbDirectory)) = 0 Then
MkDir OutFolder
End If
' Only save the active sheet.
Set xWs = Application.ActiveSheet
' Get the file extension and format number.
FileExtStr = ".xlsx"
FileFormatNum = 51
' Find the last row of data on the active sheet.
Lrow = xWs.Cells(xWs.Rows.Count, "A").End(xlUp).Row
' Turn off calculation and screen updating.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Loop through each row of data and save each row to a new file.
For i = 2 To Lrow
' Create a new workbook.
Set xWb = Application.Workbooks.Add
' Save the new workbook to the output folder.
FolderName = OutFolder & xWs.Cells(i, "A").Value & FileExtStr
' Save the active sheet to the new workbook in the output folder.
xWs.Rows(i).Copy
xWb.Worksheets(1).Range("A1").PasteSpecial xlPasteAll
' Save and close the new workbook.
xWb.SaveAs FolderName, FileFormatNum
xWb.Close False
Next i
' Turn on calculation and screen updating.
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
```
注意,这些代码应该修改以适应您的具体情况。