返回列表 上一主題 發帖

[發問] (自行解決~ 大大還是可以指導~ 提供寫法)依條件將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

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
253  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-22 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

avel

帖子
6 
主題
0 
精華
0 
積分
7 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
10 
性別
男 
註冊時間
2012-7-15 
最後登錄
2021-5-20 
4#
發表於 2012-7-15 04:14 | 只看該作者
学习了字典分组选择工作表方法。

TOP

        靜思自在 : 道德是提昇自我的明燈，不該是呵斥別人的鞭子。
返回列表 上一主題