国产一级a片免费看高清,亚洲熟女中文字幕在线视频,黄三级高清在线播放,免费黄色视频在线看

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 '拆分完畢！',,'逗號(hào)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, , '逗號(hào)Office技巧'


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub 合并當(dāng)前工作簿下的所有工作表()
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 '當(dāng)前Excel的全部工作表已經(jīng)合并完畢！', vbInformation, '提示'
End Sub

Sub 合并多個(gè)excel下所有工作表()
    '定義對話框變量，并以一個(gè)工作簿多工作表合并
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    '新建一個(gè)工作簿
    Dim newwb As Workbook
    Set newwb = Workbooks.Add
    
    With fd
        If .Show = -1 Then
            '定義單個(gè)文件變量
            Dim vrtSelectedItem As Variant
            
            '定義循環(huán)變量
            Dim i As Integer
            i = 1
            
            '開始文件檢索
            For Each vrtSelectedItem In .SelectedItems
                '打開被合并工作簿
                Dim tempwb As Workbook
                Set tempwb = Workbooks.Open(vrtSelectedItem)
                
                '定義工作表變量
                Dim tempws As Worksheet
                
                '循環(huán)復(fù)制每個(gè)工作表
                For Each tempws In tempwb.Worksheets
                    '檢查工作表名是否已存在
                    If WorksheetExists(tempws.Name, newwb) Then
                        '如果存在，則加后綴區(qū)別
                        tempws.Copy After:=newwb.Worksheets(newwb.Worksheets.Count)
                        newwb.Worksheets(newwb.Worksheets.Count).Name = tempws.Name & '_1'
                    Else
                        '如果不存在，則直接復(fù)制
                        tempws.Copy Before:=newwb.Worksheets(i)
                    End If
                    i = i + 1
                Next tempws
                
                '關(guān)閉被合并工作簿
                tempwb.Close SaveChanges:=False
            Next vrtSelectedItem
        End If
    End With
    
    Set fd = Nothing
    MsgBox Prompt:='合并完成', Buttons:=vbInformation + vbOKCancel, Title:='逗號(hào)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

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 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