返回列表 上一主題 發帖

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

hugh0620
　暱稱: VBA向前衝

高中生Rank: 3Rank: 3

帖子
559 
主題
58 
精華
0 
積分
626 
點名
0  
作業系統
win8 
軟體版本
office2013 
閱讀權限
50 
性別
男 
來自
TW 
註冊時間
2010-11-22 
最後登錄
2024-6-14 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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個檔案
                請大大們導一下~
                依條件另存新檔.rar (4.43 KB)
               
                提供自行完成的檔案
                依條件另存新檔-已完成.rar (11.33 KB)
收藏 分享
學習才能提升自己

hugh0620
　暱稱: VBA向前衝

高中生Rank: 3Rank: 3

帖子
559 
主題
58 
精華
0 
積分
626 
點名
0  
作業系統
win8 
軟體版本
office2013 
閱讀權限
50 
性別
男 
來自
TW 
註冊時間
2010-11-22 
最後登錄
2024-6-14 
2#
發表於 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
複製代碼
學習才能提升自己

TOP

        靜思自在 : 屋寬不如心寬。
返回列表 上一主題