[001]VBA拆分工作簿（不可有隐藏工作表）Sub 拆分工作薄()
Dim xpath As String
xpath = ActiveWorkbook.Path
Dim sht As Worksheet
For Each sht In ActiveWorkbook.Sheets
sht.Copy
ActiveWorkbook.SaveAs Filename:=xpath & '\' & sht.Name & '.xlsx' '将文件存放在工作薄所在的位置
ActiveWorkbook.Close
Next
MsgBox '拆分完毕！'
End Sub
[002]VBA拆分工作簿（包含隐藏工作表）Sub SplitSheetsToFiles()
' Declare variables
Dim ws As Worksheet
Dim i As Integer
Dim newBook As Workbook
' Loop through all worksheets in the workbook
For Each ws In ThisWorkbook.Sheets
If Not ws.Visible = xlSheetVeryHidden Then
Set newBook = Workbooks.Add
ws.Copy Before:=newBook.Sheets(1)
newBook.SaveAs ThisWorkbook.Path & '\' & ws.Name & '.xlsx'
newBook.Close
End If
Next ws
MsgBox '拆分完毕！',,'逗号Office技巧'
End Sub
[003]VBA拆分文件夹下所有Excel文件里面的全部工作表并保存为CSV格式（不可有隐藏工作表）Sub SplitExcelWorksheets()
Dim FolderPath As String
Dim SavePath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim NewWorkbook As Workbook
Dim i As Integer
' Prompt user to select folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = '请选择要拆分的文件夹'
.Show
If .SelectedItems.Count = 0 Then Exit Sub
FolderPath = .SelectedItems(1)
End With
' Prompt user to select save folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = '请选择要保存的文件夹'
.Show
If .SelectedItems.Count = 0 Then Exit Sub
SavePath = .SelectedItems(1)
End With
' Loop through all Excel files in folder
Filename = Dir(FolderPath & '\*.xls*')
Do While Filename <> ''
' Open Excel file
Set NewWorkbook = Workbooks.Open(FolderPath & '\' & Filename)
' Loop through all worksheets in workbook
For i = 1 To NewWorkbook.Worksheets.Count
Set Sheet = NewWorkbook.Worksheets(i)
' Save worksheet as new workbook
Sheet.Copy
ActiveWorkbook.SaveAs SavePath & '\' & Sheet.Name & '.csv', FileFormat:=xlCSV
'If you want to save to xlsx format, please change the uplink code outside：ActiveWorkbook.SaveAs SavePath & '\' & Sheet.Name & '.xlsx'
ActiveWorkbook.Close savechanges:=False
Next i
' Close original workbook
NewWorkbook.Close savechanges:=False
' Get next file name
Filename = Dir()
Loop
MsgBox Prompt:='拆分完成', Buttons:=vbInformation + vbOKCancel, Title:='逗号Office技巧'
End Sub
[004]VBA忽略隐藏工作表拆分Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2013
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook
'Create new folder to save the new files in
DateString = Format(Now, 'yyyy-mm-dd hh-mm-ss')
FolderName = Sourcewb.Path & '\' & Sourcewb.Name & ' ' & DateString
MkDir FolderName
'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy
'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = '.xls': FileFormatNum = -4143
Else
'You use Excel 2007-2013
If Sourcewb.Name = .Name Then
MsgBox 'Your answer is NO in the security dialog'
GoTo GoToNextSheet
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = '.xlsx': FileFormatNum = 51
Case 52:
If .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
End If
End With
'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& '\' & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With
End If
GoToNextSheet:
Next sh
MsgBox 'You can find the files in ' & FolderName, , '逗号Office技巧'
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
[005]VBA合并工作簿Sub 合并当前目录下所有Excel文件()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & '\' & '*.xls')
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ''
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & '\' & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range('B65536').End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range('B65536').End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range('B1').Select
Application.ScreenUpdating = True
MsgBox '共合并了' & Num & '个Excel文件下的全部工作表。如下：' & Chr(13) & WbN,vbInformation, '提示'
End Sub
[006]VBA合并工作表Sub 合并当前工作簿下的所有工作表()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
If Sheets(j).Name ActiveSheet.Name Then
X = Range('A65536').End(xlUp).Row + 1
Sheets(j).UsedRange.Copy Cells(X, 1)
End If
Next
Range('B1').Select
Application.ScreenUpdating = True
MsgBox '当前Excel的全部工作表已经合并完毕！', vbInformation, '提示'
End Sub
[007]VBA多个Excel合并为一簿多表（只合并第1个sheet）Sub Books2Sheets()
'定义对话框变量
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'新建一个工作簿
Dim newwb As Workbook
Set newwb = Workbooks.Add
With fd
If .Show = -1 Then
'定义单个文件变量
Dim vrtSelectedItem As Variant
'定义循环变量
Dim i As Integer
i = 1
'开始文件检索
For Each vrtSelectedItem In .SelectedItems
'打开被合并工作簿
Dim tempwb As Workbook
Set tempwb = Workbooks.Open(vrtSelectedItem)
'复制工作表
tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)
'把新工作簿的工作表名字改成被复制工作簿文件名，这儿应用于xlsx文件，即Excel2007的文件，如果是Excel97-2003，需要改成xls
newwb.Worksheets(i).Name = VBA.Replace(tempwb.Name, '.xlsx', '')
'关闭被合并工作簿
tempwb.Close SaveChanges:=False
i = i + 1
Next vrtSelectedItem
End If
End With
Set fd = Nothing
MsgBox Prompt:='合并完成', Buttons:=vbInformation + vbOKCancel, Title:='逗号Office技巧'
End Sub
[008]VBA合并多个excel文件下所有工作表（一簿多表）Sub 合并多个excel下所有工作表()
'定义对话框变量，并以一个工作簿多工作表合并
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'新建一个工作簿
Dim newwb As Workbook
Set newwb = Workbooks.Add
With fd
If .Show = -1 Then
'定义单个文件变量
Dim vrtSelectedItem As Variant
'定义循环变量
Dim i As Integer
i = 1
'开始文件检索
For Each vrtSelectedItem In .SelectedItems
'打开被合并工作簿
Dim tempwb As Workbook
Set tempwb = Workbooks.Open(vrtSelectedItem)
'定义工作表变量
Dim tempws As Worksheet
'循环复制每个工作表
For Each tempws In tempwb.Worksheets
'检查工作表名是否已存在
If WorksheetExists(tempws.Name, newwb) Then
'如果存在，则加后缀区别
tempws.Copy After:=newwb.Worksheets(newwb.Worksheets.Count)
newwb.Worksheets(newwb.Worksheets.Count).Name = tempws.Name & '_1'
Else
'如果不存在，则直接复制
tempws.Copy Before:=newwb.Worksheets(i)
End If
i = i + 1
Next tempws
'关闭被合并工作簿
tempwb.Close SaveChanges:=False
Next vrtSelectedItem
End If
End With
Set fd = Nothing
MsgBox Prompt:='合并完成', Buttons:=vbInformation + vbOKCancel, Title:='逗号Office技巧'
End Sub
Function WorksheetExists(shtName As String, wb As Workbook) As Boolean
'检查工作表名是否已存在
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
[009]VBA合并文件夹下所有excel文件到一个工作表中（保持原有行高）Sub MergeExcelFiles()
'定义变量,需统一的行高
Dim wbk As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim wsDest As Worksheet
Dim rngDest As Range
Dim rngCopy As Range
Dim intLastRow As Long
Dim intLastCol As Long
Dim intDestRow As Long
Dim intDestCol As Long
'选择文件夹
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = 'Select a Folder'
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub '如果用户点击取消，则退出
myPath = .SelectedItems(1) & '\' '存储所选文件夹的路径
End With
'创建新工作簿并选择第一个工作表作为合并的目标
Set wbk = Workbooks.Add(xlWBATWorksheet)
Set wsDest = wbk.Worksheets(1)
Set rngDest = wsDest.Range('A1')
'循环遍历文件夹中的所有Excel文件
myFile = Dir(myPath & '*.xls*')
intDestRow = 1 '初始化目标行数
Do While myFile <> ''
'打开文件并将数据复制到目标工作表中
Set rngCopy = Workbooks.Open(myPath & myFile).Worksheets(1).UsedRange
intLastRow = rngCopy.Rows.Count
intLastCol = rngCopy.Columns.Count
rngCopy.Copy wsDest.Cells(intDestRow, 1)
'调整目标区域
wsDest.Range(wsDest.Cells(intDestRow, 1), wsDest.Cells(intDestRow + intLastRow - 1, intLastCol)).EntireRow.RowHeight = rngCopy.EntireRow.RowHeight
wsDest.Range(wsDest.Cells(intDestRow, 1), wsDest.Cells(intDestRow + intLastRow - 1, intDestCol + intLastCol - 1)).EntireColumn.ColumnWidth = rngCopy.EntireColumn.ColumnWidth
intDestRow = intDestRow + intLastRow '更新目标行数
'关闭源工作簿
Workbooks(myFile).Close SaveChanges:=False
'获取下一个文件
myFile = Dir
Loop
End Sub
[010]VBA一键批量修改工作表名称Sub 一键获取工作表名称()
Dim sht As Worksheet, k&
[A:A] = ''
[A1] = '原工作表名称'
j = 1
For Each sht In Worksheets
j = j + 1
Cells(j, 1) = sht.Name
Next
End Sub
Sub 一键修改工作表名称()
Dim shtname$, sht As Worksheet, i&
On Error Resume Next
For i = 1 To Cells(Rows.Count, 1).End(3).Row
shtname = Cells(i, 1)
Set sht = Sheets(shtname)
If Err = 0 Then
Sheets(shtname).Name = Cells(i, 2)
Else
Err.Clear
End If
Next
End Sub
[011]VBA对多个工作表同时排序Sub SortMultipleWorksheets()
Dim ws As Worksheet
Dim sortOrder As Integer
'Ask user for sort order
sortOrder = InputBox('如果输入1，则数据将按升序排序；如果输入2，则数据将按降序排序；如果输入无效的选项，则排序将取消。')
'Loop through each worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
If sortOrder = 1 Then
'Sort data based on column B in ascending order, excluding the first row
.Range('B2', .Range('B' & .Rows.Count).End(xlUp)).Sort Key1:=.Range('B2'), Order1:=xlAscending
ElseIf sortOrder = 2 Then
'Sort data based on column B in descending order, excluding the first row
.Range('B2', .Range('B' & .Rows.Count).End(xlUp)).Sort Key1:=.Range('B2'), Order1:=xlDescending
Else
MsgBox '无效选项。排序已取消。',,'逗号Ofiice技巧'
Exit Sub
End If
End With
Next ws
End Sub
[012]VBA一键删除全部隐藏工作表Sub DeleteHiddenSheets()
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetHidden Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
End Sub
[013]VBA一键批量多工作表多列同时求和Sub SumOfColumns()
Dim ws As Worksheet
Dim wb As Workbook
Dim colLetters As String
Set wb = ThisWorkbook
colLetters = InputBox('请输入需要求和列的字母，用空格隔开：', '逗号Office技巧')
For Each ws In wb.Sheets
If ws.Name <> '' Then
Dim colLetterArray As Variant
colLetterArray = Split(colLetters, ' ')
For i = 0 To UBound(colLetterArray)
ws.Range(colLetterArray(i) & ws.Rows.Count).End(xlUp).Offset(1, 0) = '=SUM(' & colLetterArray(i) & '1:' & colLetterArray(i) & ws.Range(colLetterArray(i) & ws.Rows.Count).End(xlUp).Row & ')'
Next i
End If
Next ws
End Sub
|
