[已解决]有关工作表移动的问题

503244002

各位大神我想把EXCEL中的工作表的名字提取第9个和第10个字符，只要提取出来的是相同数字，那么就取定这些工作表，然后移到到一个新的工作簿中去。比如“117004JC11013”和“117004JC11012”这两个工作表第9个和第10个字符都是“11”那么就同时被选取，然到移到到另一个工作簿中。然后再选定下一组。求代码！！！


备注：我的工作簿里有很多个工作表

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-19 22:01

执行代码后会在当前工作簿所在的路径下生产相应的工作簿：

1. Sub xx()
   
2.     Dim d, arr, i&, j&, s$, wb As Workbook
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     For i = 1 To ThisWorkbook.Sheets.Count
   
5.         s = Mid(Sheets(i).Name, 9, 2)
   
6.         If s <> "" Then
   
7.             If d.Exists(s) Then
   
8.                 d(s) = d(s) & ";" & Sheets(i).Name
   
9.             Else
   
10.                 d.Add s, Sheets(i).Name
    
11.             End If
    
12.         End If
    
13.     Next
    
14.     Application.ScreenUpdating = False
    
15.     For Each k In d.Keys
    
16.         If InStr(d(k), ";") > 0 Then
    
17.             arr = Split(d(k), ";")
    
18.             Set wb = Workbooks.Add
    
19.             For i = 0 To UBound(arr)
    
20.                 ThisWorkbook.Sheets(arr(i)).Copy wb.Sheets(i + 1)
    
21.             Next
    
22.             wb.SaveAs ThisWorkbook.Path & "" & k & ".xlsx"
    
23.             wb.Close
    
24.         End If
    
25.     Next
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

执行代码后会在当前工作簿所在的路径下生产相应的工作簿：

1. Sub xx()
   
2.     Dim d, arr, i&, j&, s$, wb As Workbook
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     For i = 1 To ThisWorkbook.Sheets.Count
   
5.         s = Mid(Sheets(i).Name, 9, 2)
   
6.         If s <> "" Then
   
7.             If d.Exists(s) Then
   
8.                 d(s) = d(s) & ";" & Sheets(i).Name
   
9.             Else
   
10.                 d.Add s, Sheets(i).Name
    
11.             End If
    
12.         End If
    
13.     Next
    
14.     Application.ScreenUpdating = False
    
15.     For Each k In d.Keys
    
16.         If InStr(d(k), ";") > 0 Then
    
17.             arr = Split(d(k), ";")
    
18.             Set wb = Workbooks.Add
    
19.             For i = 0 To UBound(arr)
    
20.                 ThisWorkbook.Sheets(arr(i)).Copy wb.Sheets(i + 1)
    
21.             Next
    
22.             wb.SaveAs ThisWorkbook.Path & "" & k & ".xlsx"
    
23.             wb.Close
    
24.         End If
    
25.     Next
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码