Board logo

標題: [發問] (自行解決~ 大大還是可以指導~ 提供寫法)依條件將sheet另存新檔 [打印本頁]
作者: hugh0620    時間: 2012-7-5 16:49     標題: (自行解決~ 大大還是可以指導~ 提供寫法)依條件將sheet另存新檔

本帖最後由 hugh0620 於 2012-7-6 14:51 編輯

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個檔案
                請大大們導一下~
               [attach]11587[/attach]
               
                提供自行完成的檔案
                [attach]11605[/attach]
作者: hugh0620    時間: 2012-7-6 14:48

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

主要是在一開始寫的時候~ 當我新增一個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. '=================

  10. A = Sheet1.Range("E65536").End(xlUp).Row

  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

  37. Next
  38. Application.DisplayAlerts = True
  39. End Sub
複製代碼
作者: Hsieh    時間: 2012-7-6 16:07

回復 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    時間: 2012-7-15 04:14

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)