infoverdad

¦^´_ 1# jimmuLu

1. Sub Exx()
   
2. '¦X¨Ö¦P¤@¸ê®Æ§¨¤º©Ò¦³ExcelÀɤ§Sheet¤u§@ªí
   
3. Dim NewName As String
   
4. Dim MyBook As Workbook
   
5. Dim MyFile$, i%, k%
   
6. 
   
7. MyFile = Dir(ThisWorkbook.Path & "\*.xls")
   
8. Set MyBook = ThisWorkbook
   
9. 
   
10. i = 1
    
11. Application.ScreenUpdating = False
    
12. Do While MyFile <> ""
    
13.   If MyFile <> MyBook.Name Then
    
14.      With Workbooks.Open(ThisWorkbook.Path & "\" & MyFile)
    
15.      For k = 1 To Sheets.Count
    
16.         Sheets(k).Select
    
17.         ActiveSheet.Range("a1").Select
    
18.         NewName = Left(MyFile, Len(MyFile) - 4)
    
19.         ActiveSheet.Copy After:=MyBook.Sheets(MyBook.Sheets.Count)
    
20.         ActiveSheet.Name = NewName & "_" & k
    
21.      Next k
    
22.      k = 1
    
23.      Application.DisplayAlerts = False
    
24.      .Close
    
25.        On Error Resume Next
    
26.      End With
    
27.   End If
    
28.   MyFile = Dir
    
29. Loop
    
30. Application.ScreenUpdating = True
    
31. End Sub

½Æ»s¥N½X