[發問] (自行解決~ 大大還是可以指導~ 提供寫法)依條件將sheet另存新檔

hugh0620

Dear 大大們
               小弟卡到一個問題~ 如附件
                共有5個sheet  (原始資料不止5個sheet)
                1. Data
                2. 1,2,3,4 為要另存的sheet

                問題如下:
                1. 依data的條件
                         a有:1,2
                         b有:1,2,3,4
                 2. 只要a符合1,就是1&2 的sheet,另存1個檔案
                              b符合2,就是3&4 的sheet,另存1個檔案
                請大大們導一下~
                依條件另存新檔.rar (4.43 KB)

下載次數: 9

2012-7-5 16:26

               
                提供自行完成的檔案
                依條件另存新檔-已完成.rar (11.33 KB)

下載次數: 11

2012-7-6 14:51

hugh0620

以下是針對我發文的問題~ 自行拼湊出來的解決方式~

主要是在一開始寫的時候~ 當我新增一個workbooks時~
在跑For each Sh in [    ]時~ 老是去撈取新增的 workbooks~ 就卡在那邊
因為知道是哪邊出了問題~ 但對於workbooks /sheets / ThisWorkbook.Worksheets ...這些的用法不是很熟悉~
所以~ 一直測試~ 終於找到適合的指令~

若大大有這方面的資訊~ 或是有其他更好的寫法~ 亦不吝指導一下~

1. Sub ex()
   
2. Application.DisplayAlerts = False
   
3. Dim Sh As Worksheet
   
4. '====進階篩選=====
   
5.     Range("B4:B8").Select
   
6.     Range("B4:B8").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E4" _
   
7.         ), Unique:=True
   
8. '=================
   
9. 
   
10. A = Sheet1.Range("E65536").End(xlUp).Row
    
11. 
    
12. For I = 5 To A
    
13.     H = Sheet1.Range("E" & I)
    
14.     Workbooks.Add
    
15.     k = ActiveWorkbook.Name
    
16.         For J = 5 To 8
    
17.             For Each Sh In ThisWorkbook.Worksheets
    
18.                 If Sh.Name = Sheet1.Range("C" & J) And H = Sheet1.Range("B" & J) Then
    
19.                    With ThisWorkbook.Worksheets(Sh.Name)
    
20.                         .Copy Before:=Workbooks(k).Sheets(1)
    
21.                    End With
    
22.                 End If
    
23.             Next
    
24.         Next
    
25.                 With ActiveWorkbook
    
26.                      If Sheets.Count > 1 Then
    
27.                          .Sheets("Sheet1").Delete
    
28.                          .SaveAs "C:\Documents and Settings\Hugh.Huang\桌面\新資料夾\" & H
    
29.                          .Close
    
30.                      Else
    
31.                          .Sheets("Sheet1").Name = "無"
    
32.                          .SaveAs "C:\Documents and Settings\Hugh.Huang\桌面\新資料夾\" & H
    
33.                          .Close
    
34.                      End If
    
35.                 End With
    
36. 
    
37. Next
    
38. Application.DisplayAlerts = True
    
39. End Sub

複製代碼

Hsieh

回復 2# hugh0620

工作表群組複製

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With Sheet1
   
4. For Each A In .Range(.[B5], .[B5].End(xlDown))
   
5.   d(A.Value) = IIf(d(A.Value) = "", A.Offset(, 1), d(A.Value) & "," & A.Offset(, 1))
   
6. Next
   
7. For Each ky In d.keys
   
8.   Sheets(Split(d(ky), ",")).Copy
   
9.   With ActiveWorkbook
   
10.      .SaveAs "D:\" & ky & ".xls"
    
11.      .Close 1
    
12.   End With
    
13. Next
    
14. End With
    
15. End Sub

複製代碼

avel

学习了字典分组选择工作表方法。