各位好，我又來了，我遇到一個奇怪的狀況，全選複製就當機。

shibuy wrote:
我重新修改程式，流程如下 :(恕刪)

Sub test()
    
    'excel視窗保持可見
    '目錄內所有xls 、 xlsx 、 xls*，會同時處理，含全部工作表
    '程式碼不是放在有問題的檔案，需放在“新建”的檔案內
    '自訂格式…那些，都不會複製，不是bug，是沒寫

    Dim Get_Path As Object, Default_Path As Variant, xls_fullpath As Variant, ttt As Double, Report As String
    Dim New_file As Object, New_book As Workbook, Old_file As Workbook, temp() As Variant
    Dim Source_Range  As Range, Target_Range As Range, Last_Row As Integer, Last_Col As Integer
    
    Default_Path = &H11& 'My computer 'ThisWorkbook.Path
    Set Get_Path = CreateObject("Shell.Application").BrowseForFolder(0, "choose a folder", &H201, Default_Path)
     
    If Get_Path Is Nothing Then
        MsgBox "???"
        Exit Sub
    End If
        
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set New_file = CreateObject("excel.application")
    New_file.Visible = True

    For Each xls_fullpath In Get_Path.items
    
        ttt = Timer
        DoEvents
        If xls_fullpath.Path Like "*.xls*" And Not xls_fullpath.isfolder And xls_fullpath.Name & ".xlsm" <> ThisWorkbook.Name Then
            
            Set Old_file = Workbooks.Open(xls_fullpath.Path, , False)
            
            For i = 1 To Old_file.Sheets.Count
                If i = 1 Then
                    Set New_book = New_file.Workbooks.Add
                    New_book.Sheets(1).Name = Old_file.Sheets(1).Name
                Else
                    New_book.Sheets.Add(After:=New_book.Sheets(New_book.Sheets.Count)).Name = Old_file.Sheets(i).Name
                End If
                
                Last_Row = Old_file.Sheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Row
                Last_Col = Old_file.Sheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Column

                If Last_Row = 1 And Last_Col = 1 And Old_file.Sheets(i).Range("a1") = "" Then
                    'empty sheet
                Else
                    Set Source_Range = Old_file.Sheets(i).Range("a1").Resize(Last_Row, Last_Col)
                    Set Target_Range = New_book.Sheets(i).Range("a1").Resize(Last_Row, Last_Col)
                    Target_Range.Formula = Source_Range.Formula '文字、公式
                    'Target_Range = Source_Range '文字
                    'New_book.Sheets(i).Cells.EntireColumn.AutoFit
                End If
            Next
            
            Report = Report & Old_file.Name & "：" & Timer - ttt & "秒" & vbNewLine
            New_book.SaveAs (Get_Path.self.Path & "\(" & Format(Now(), "yyyymmdd hhmmss") & ")" & xls_fullpath.Name), xlOpenXMLWorkbook
            New_book.Close 1
            Old_file.Close 1
                        
            
            Set Old_file = Nothing
            Set New_book = Nothing
            Set Source_Range = Nothing
            Set Target_Range = Nothing
            
        End If
    Next
        
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    New_file.Quit
    Set New_file = Nothing
    Set Get_Path = Nothing
    
    
    MsgBox IIf(Report = "", "excel file?", Report)
    
End Sub

snare wrote:
謝謝您分享這麼高明的python...(恕刪)

snare wrote:
謝謝您分享這麼高明的python...(恕刪)