[發問] 請教如何使用vba遍歷各工作表之相同範圍內容COPY至主頁並適時新增Columns數

cmo140497

Dear 版主或各位大大們 :
小弟因為sheet上方會有些圖表,設定為不隨儲存格大小作變動,但又需取得其它sheet之資料(其來源行列數會變動),是否可以每個Sheet之相同位址b2:p12,分別複製資料至Sheet1 b5位址開始,如遇欄位數不足,自動新增來源之columns數,每排僅能有三個範圍資料,第四個則跳第二排,直至結束

下載 (84.22 KB)

2013-1-23 17:26

Get each sheet data to mainsheet_2013-01-23.zip (27 KB)

下載次數: 5

2013-1-23 17:27

stillfish00

回復 1# cmo140497
1.
>>如遇欄位數不足,自動新增來源之columns數,
敘述看不懂

2.
>>每排僅能有三個範圍資料,第四個則跳第二排
檔案跟圖上顯示的是
僅有二個範圍資料,第三個則跳第二排
   
3.
不過我大該可以猜出你要甚麼...
試看看..

1. Sub Test()
   
2. Dim vCols As Long, cIndex As Long, rIndex As Long
   
3. Dim first As Long, last As Long
   
4. Dim sCopy As String
   
5. Dim r, c
   
6. 
   
7. first = 2   'from T02 , 可自行調整
   
8. last = 5    'to   T05 , 可自行調整
   
9. sCopy = "B2:P12"       '可自行調整
   
10. 
    
11. r = Range(sCopy).Rows.Count + 1     '每區塊列數,+1列標題(Wafer TXX)
    
12. c = Range(sCopy).Columns.Count + 1  '每區塊欄數,+1欄空白
    
13. 
    
14. '可見的欄數總數
    
15. vCols = Sheets("sheet1").Cells.SpecialCells(xlCellTypeVisible).Columns.Count
    
16. 
    
17. For i = first To last
    
18.     rIndex = Int((i - first) / Int(vCols / c))
    
19.     cindex = (i - first) Mod Int(vCols / c)
    
20.    
    
21.     With Sheets("sheet1").[B5].Offset(r * rIndex, c * cindex)
    
22.         .Offset(-1, 1).Value = "WAFER"
    
23.         .Offset(-1, 2).Value = "T" & Format(i, "00")
    
24.         Sheets("T" & Format(i, "00")).Range(sCopy).Copy .Cells(1, 1)    '範圍複製[B2:P12],含格式
    
25.     End With
    
26. Next i
    
27. End Sub

複製代碼

cmo140497

回復 2# stillfish00


    您實在太神了,小弟腦筋太死了,其實以版面為主才對,不應該用以新增COLUMNS數,實在太感謝您了,感恩!

cmo140497

回復 2# stillfish00


    不好意思,小弟還有一個問題忘了提問,那就是假如Sheets name也不都是T開頭,Sheets數也不太一定只有4個,小弟知道要如何count sheets,但也如何避免其它二頁也被copy進來,請問要如何修正為動態,實在再麻煩您予以指導,感恩!

stillfish00

回復 4# cmo140497
能舉個例嗎?
>>避免其它二頁也被copy進來
哪兩頁? 有sheet name和 sheet位置順序嗎?
這兩頁外的都要copy嗎?

cmo140497

回復 5# stillfish00

不好意思,就main & cals 這兩個sheet資料怕會被copy進來,另如果其它sheet name不是01.02.03的序列,不知要如何代入,再煩請您指導,感恩!


    Get each sheet data to mainsheet_已回覆.zip (36.29 KB)

下載次數: 7

2013-1-24 22:47

cmo140497

[/code][b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=50094&ptid=8871]6#[/url] [i]cmo140497[/i] [/b]

不好意思,小弟試出來了,用worksheets(index)就OK了,不過仍感謝您的指點迷津,感恩!

[code]Sub Test()
Dim vCols As Long, cIndex As Long, rIndex As Long
Dim first As Long, last As Long
Dim sCopy As String
Dim r, c
Dim myshtc As Long

Worksheets(1).Rows("48:99").Clear

myshtc = ThisWorkbook.Sheets.Count

first = 3   
last = myshtc   
sCopy = "B6:P16"      

r = Range(sCopy).Rows.Count + 1     
c = Range(sCopy).Columns.Count + 1  

'可見的欄數總數
vCols = Sheets("DashBoard").Cells.SpecialCells(xlCellTypeVisible).Columns.Count

For i = first To last
    rIndex = Int((i - first) / Int(vCols / c))
    cIndex = (i - first) Mod Int(vCols / c)
    newR = r * rIndex
    newC = c * cIndex
   
    With Sheets("DashBoard").[R50].Offset(newR, newC)
        .Offset(-1, 1).Value= "ID"        
        .Offset(-1, 2).Value = Worksheets(i).Name        
        Worksheets(i).Range(sCopy).Copy .Cells(1, 1)   
    End With
Next i
End Sub

stillfish00

回復 7# cmo140497
資料沒缺嗎?
With Sheets("DashBoard").[R50].Offset(newR, newC)   
R50為起始點 ,  vCols應定為
vCols = Sheets("DashBoard").Cells.SpecialCells(xlCellTypeVisible).Columns.Count-49
除非你A:Q都隱藏

Hsieh

回復 7# cmo140497

1. Sub ex()
   
2. With Sheets("summary")
   
3. s = .Cells.SpecialCells(xlCellTypeVisible).Columns.Count - 2
   
4. .Cells = ""
   
5. a = 2: b = 4 '寫入的第一個位置
   
6.    For Each sh In Sheets
   
7.        If sh.Name <> .Name And sh.Name <> "cals" Then '排除不寫入的工作表
   
8.        ar = sh.Range("A1").CurrentRegion.Offset(, 1).Value '所有資料範圍
   
9.            ar(1, 2) = ar(1, 1): ar(1, 1) = sh.[A1].Value '更改陣列內容
   
10.            r = Int(n / Int(s / (UBound(ar, 2) - 1))) * (UBound(ar, 1) - 1) + b
    
11.            k = (n Mod Int(s / (UBound(ar, 2) - 1))) * (UBound(ar, 2) - 1) + a
    
12.            n = n + 1 '計算工作表數量
    
13.            .Cells(r, k).Resize((UBound(ar, 1) - 1), (UBound(ar, 2) - 1)) = ar
    
14.        End If
    
15.    Next
    
16. End With
    
17. End Sub

複製代碼