[發問]儲存格設定範圍分割成不同工作表

kilon

請教板上先進，最近在會計上處理一份資料
參閱附件　 儲存格設定範圍分割成不同工作表.zip (13.07 KB)

下載次數: 9

2012-8-28 11:42

1.希望可以將黃色彼此中間的範圍分開成不同的工作表
　較有邏輯的是每張報表結束時，都有個”報表結束”

2.同時希望命名的方式是以藍色的部分
　但目前只能抓到比較固定的關係是藍色的部分跟上一張報表結束的相對位置是固定的

想請問這可以怎麼寫呢？
還麻煩各位大大了，感謝！

white945

回復 1# kilon

1. Sub SplitSheet()
   
2. Dim A As Range, B As Range, r%, Sh As Worksheet
   
3. Set A = [A1] 'A1為起點
   
4. Do Until A.Address = first '直到再度找到的位置是A1
   
5. first = "$A$1"
   
6. Set B = Columns("G").Find("報 表 結 束", after:=A.Offset(, 6)) 'G欄中找到報表結束
   
7. r = B.Row - A.Row
   
8. ad = A.Resize(r + 1, 13).Address
   
9. Set Sh = Worksheets.Add(after:=Sheets(Sheets.Count))
   
10. Sh.Name = Replace(A.Offset(3, 3).Text, "/", "")
    
11. A.Resize(r + 1, 13).Copy Sh.[A1]
    
12. Set A = Columns("A").Find(A, after:=A) '找下一個起點
    
13. Loop
    
14. End Sub

複製代碼

GBKEE

回復 2# white945
white945: 你的程式要註明 必須複製在這工作表的模組中 ,如複製到其他模組 只能複製工作表 "其他營業外收益" 後會離開迴圈.

1. 如複製到其他模組
   
2. Set Sh = Worksheets.Add(after:=Sheets(Sheets.Count))  '此為作用中的工作表
   
3. Sh.Name = Replace(A.Offset(3, 3).Text, "/", "")
   
4. A.Resize(r + 1, 13).Copy Sh.[A1]
   
5. Set A = Columns("A").Find(A, after:=A)   
   
6. '會是在作用工作表 中尋找 A.Address = first

複製代碼

修改後可在任何模組執行

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh As Worksheet, A As Range, G As Range, A_Address
   
4.     Set Sh = Sheet1
   
5.     Set A = Sh.Columns(1).Find("科目編號範圍", LookAT:=xlWhole, after:=Cells(Rows.Count, 1))
   
6.     '最後一列找起
   
7.     'Find: 預設會從第1列之後開使找起 '不指定:第一個找到會是[A40]
   
8.     A_Address = A.Address
   
9.     Do
   
10.         Set G = Sh.Columns(7).Find("***  報 表 結 束  ***", LookAT:=xlWhole, after:=Cells(A.Row, 7))
    
11.         Sheets.Add(, Sheets(Sheets.Count)).Name = Replace(A.Cells(4, 4), "/", "-") ' '所得稅費用/利益 "/" 不符合命名規則
    
12.         Range(A, G).EntireRow.Copy ActiveSheet.Range("a1")
    
13.         Set A = Sh.Columns(1).Find("科目編號範圍", LookAT:=xlWhole, after:=A)
    
14.     Loop Until A.Address = A_Address
    
15. End Sub

複製代碼

white945

回復 3# GBKEE

多謝版主提醒

1. Sub SplitSheet()
   
2. Dim A As Range, B As Range, r%, Sh As Worksheet
   
3. With Sheet1
   
4. Set A = .[A1] 'A1為起點
   
5. Do Until A.Address = first '直到再度找到的位置是A1
   
6. first = "$A$1"
   
7. Set B = .Columns("G").Find("報 表 結 束", after:=A.Offset(, 6)) 'G欄中找到報表結束
   
8. r = B.Row - A.Row
   
9. Set Sh = Worksheets.Add(after:=Sheets(Sheets.Count))
   
10. Sh.Name = Replace(A.Offset(3, 3).Text, "/", "")
    
11. A.Resize(r + 1, 13).Copy Sh.[A1]
    
12. Set A = .Columns("A").Find(A, after:=A) '找下一個起點
    
13. Loop
    
14. End With
    
15. End Sub

複製代碼

kilon

感謝大大 我試試看!!!

回復 4# white945

kilon

white 大大
用你的程式碼，會在"r = B.Row - A.Row" 發生錯誤，錯誤的原因是沒有設定物件變數或 With 區塊變數
是因為在Dim那邊沒有針對r設定變數嗎?

b]回復 4# white945

kilon

版主大大，你的成功！
不過我遇到一個問題，因為目前給的資料上都只有一頁的報表，但有些其實大於二頁，ex:營業外收入

附件如下：
附件.zip (18.15 KB)

下載次數: 5

2012-9-3 15:45

灰色是新增的部分，而藍色特別標示是因為跟報表結束的二頁中間差距比起來是不同的

請問這樣子要如何修改呢？
目前自己測試到目前的結果好像是在之前抓範圍的時候，會重複抓到範圍，導致命名會重複
不過其實自己也不確定．．．這個VBA其實寫的我還沒有辦法參透呀...
麻煩大大們了!

回復 3# GBKEE

Hsieh

回復 7# kilon

1. Sub nn()
   
2. Dim A As Range, B As Range, r%, Sh As Worksheet
   
3. With Sheet1
   
4. Set A = .[A1] 'A1為起點
   
5. Do Until A.Address = first '直到再度找到的位置是A1
   
6. Set B = .Columns("G").Find("***  報 表 結 束  ***", after:=A.Offset(, 6)) 'G欄中找到報表結束
   
7. r = B.Row - A.Row
   
8. Set Sh = Worksheets.Add(after:=Sheets(Sheets.Count))
   
9. Sh.Name = Replace(A.Offset(3, 3).Text, "/", "")
   
10. A.Resize(r + 1, 13).Copy Sh.[A1]
    
11. Do Until A.Row > B.Row Or A.Address = first '避免一個報表結束內有1個以上科目
    
12.   Set A = .Columns("A").Find(A, after:=A) '找下一個起點
    
13. Loop
    
14. first = "$A$1"
    
15. Loop
    
16. End With
    
17. End Sub

複製代碼

kilon

回復 8# Hsieh

謝謝!!成功了!!
可以麻煩大大看看我對這個程式碼的的邏輯理解是否正確

Sub SplitSheet()　
Dim A As Range, B As Range, r%, Sh As Worksheet　不懂這裡設定r%是什麼意思
With Sheet1
Set A = .[A1] 'A1為起點
Do Until A.Address = first '直到再度找到的位置是A1
first = "$A$1"
Set B = .Columns("G").Find("報 表 結 束", after:=A.Offset(, 6)) 'G欄中找到報表結束
r = B.Row - A.Row

這邊我有點不太理解
只知道找到報表結束，但after:=A.Offset(, 6) 這個寫法我不曉得什麼意思，這樣抓到的範圍是什麼？
另外r = B.Row - A.Row 我想應該上一個問題解決完這個部分應該就可以理解:)

Set Sh = Worksheets.Add(after:=Sheets(Sheets.Count))　
Sh.Name = Replace(A.Offset(3, 3).Text, "/", "")
A.Resize(r + 1, 13).Copy Sh.[A1]

請問這邊的Resize是什麼功能？

Set A = .Columns("A").Find(A, after:=A) '找下一個起點

這個應該跟第一個問題after:=A.Offset(, 6)有關係吧...

Loop
End With
End Sub

感謝大大

Hsieh

回復 9# kilon

Set B = .Columns("G").Find("報 表 結 束", after:=A.Offset(, 6))
這是因為要在G欄中找到字串，而尋找的位置必須是找到所要的科目位置(A的位置)以後
故此設定尋找的after參數，從A列所在儲存格以下的G欄開始尋找
Resize式擴展區域的意思
從A的位置擴展成r+1列，13欄的範圍，作為要複製的範圍
A是在A欄，像又擴展13欄才會變成A:M欄