[已解决]求高手编个宏。实现如附件所示效果

tzjx200521

如何获得题目的效果，求老师解答。

最佳答案

月排行榜 / 总排行榜

hylees

2012-3-17 13:30

1. Sub a()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim sh As Worksheet, st As String, wb As Workbook, str As String
   
5.     Dim d
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For Each sh In ThisWorkbook.Worksheets
   
8.         st = sh.Name
   
9.         str = Replace(Right(st, Len(st) - InStr(st, "（")), "）", "")
   
10.         If d.exists(str) Then
    
11.             sh.Copy after:=Workbooks(str & ".xls").Sheets(Workbooks(str & ".xls").Sheets.Count)
    
12.             Workbooks(str & ".xls").Save
    
13.         Else
    
14.             d(str) = ""
    
15.             sh.Copy
    
16.             Set wb = ActiveWorkbook
    
17.             wb.SaveAs ThisWorkbook.Path & "" & str & ".xls"
    
18.         End If
    
19.         Next sh
    
20.         ThisWorkbook.Save
    
21.         Workbooks.Close
    
22.         Application.DisplayAlerts = True
    
23.         Application.ScreenUpdating = True
    
24.     End Sub

复制代码

跳转到最佳答案楼层

hylees

1. Sub a()
   
2.     Application.ScreenUpdating = False
   
3.     Dim sh As Worksheet, st As String, wb As Workbook, str As String
   
4.         For Each sh In ThisWorkbook.Worksheets
   
5.             st = sh.Name
   
6.             str = Replace(Right(st, Len(st) - InStr(st, "（")), "）", "")
   
7.         sh.Copy
   
8.         Set wb = ActiveWorkbook
   
9.         wb.SaveAs ThisWorkbook.Path & "" & str & ".xls"
   
10.         wb.Close True
    
11.     Next sh
    
12.     Application.ScreenUpdating = True
    
13. End Sub

复制代码

用这代码就可以了

tzjx200521

这个代码只能实现只有一个工作表的，，如果多个呢。。如题所示。。。

hylees

多个名称相同的你要怎么处理类！  要把问题一次弄好的哇！
  工作薄名称直接以工作表名称来命名不是好的！

tzjx200521

括号里相周的放在一个工作簿啊

hylees

1. Sub a()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim sh As Worksheet, st As String, wb As Workbook, str As String
   
5.     Dim d
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For Each sh In ThisWorkbook.Worksheets
   
8.         st = sh.Name
   
9.         str = Replace(Right(st, Len(st) - InStr(st, "（")), "）", "")
   
10.         If d.exists(str) Then
    
11.             sh.Copy after:=Workbooks(str & ".xls").Sheets(Workbooks(str & ".xls").Sheets.Count)
    
12.             Workbooks(str & ".xls").Save
    
13.         Else
    
14.             d(str) = ""
    
15.             sh.Copy
    
16.             Set wb = ActiveWorkbook
    
17.             wb.SaveAs ThisWorkbook.Path & "" & str & ".xls"
    
18.         End If
    
19.         Next sh
    
20.         ThisWorkbook.Save
    
21.         Workbooks.Close
    
22.         Application.DisplayAlerts = True
    
23.         Application.ScreenUpdating = True
    
24.     End Sub

复制代码