麻辣家族討論版版 - Powered by Discuz! Board

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

作者: cmo140497 時間: 2013-1-23 17:28 標題: 請教如何使用vba遍歷各工作表之相同範圍內容COPY至主頁並適時新增Columns數

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

[attach]14055[/attach]

[attach]14056[/attach]

作者: stillfish00 時間: 2013-1-24 19:15

本帖最後由 stillfish00 於 2013-1-24 19:16 編輯

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

2.
>>每排僅能有三個範圍資料,第四個則跳第二排
檔案跟圖上顯示的是
僅有二個範圍資料,第三個則跳第二排

3.
不過我大該可以猜出你要甚麼...
試看看..

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
first = 2 'from T02 , 可自行調整
last = 5 'to T05 , 可自行調整
sCopy = "B2:P12" '可自行調整
r = Range(sCopy).Rows.Count + 1 '每區塊列數,+1列標題(Wafer TXX)
c = Range(sCopy).Columns.Count + 1 '每區塊欄數,+1欄空白
'可見的欄數總數
vCols = Sheets("sheet1").Cells.SpecialCells(xlCellTypeVisible).Columns.Count
For i = first To last
rIndex = Int((i - first) / Int(vCols / c))
cindex = (i - first) Mod Int(vCols / c)
With Sheets("sheet1").[B5].Offset(r * rIndex, c * cindex)
.Offset(-1, 1).Value = "WAFER"
.Offset(-1, 2).Value = "T" & Format(i, "00")
Sheets("T" & Format(i, "00")).Range(sCopy).Copy .Cells(1, 1) '範圍複製[B2:P12],含格式
End With
Next i
End Sub

複製代碼

作者: cmo140497 時間: 2013-1-24 19:52

回復 2# stillfish00

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

作者: cmo140497 時間: 2013-1-24 20:13

回復 2# stillfish00

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

作者: stillfish00 時間: 2013-1-24 21:12

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

作者: cmo140497 時間: 2013-1-24 22:47

回復 5# stillfish00

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

[attach]14061[/attach]

作者: cmo140497 時間: 2013-1-24 23:49

[/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 時間: 2013-1-25 01:37

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

作者: Hsieh 時間: 2013-1-25 09:20

回復 7# cmo140497

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

複製代碼

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