VBA代码大全（更新2023.02.12）

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

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

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

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

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

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

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

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

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

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