返回列表 上一主題 發帖

複製多個工作表的內容

lovegowan

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
win10 
軟體版本
office 2016 
閱讀權限
10 
註冊時間
2019-8-17 
最後登錄
2021-7-22 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2019-8-22 21:08 | 只看該作者

複製多個工作表的內容

大家好，這是第一次發文

小妹不才..目前正在學習中，最近需要處理大量的資料

需要將每日的工作表大量彙整，說明 多個工作表複製.rar (13.58 KB) 如附檔

只想的到先用公式INDIRECT或者寫單一從各工作表複製貼上
但一項一項改很耗時，所以來請教....

謝謝各位不吝指教 :)

每日的工作表如下圖


需要將每日的項目以橫向的方式貼至下圖


非常感謝(鞠躬)
收藏 分享

lovegowan

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
win10 
軟體版本
office 2016 
閱讀權限
10 
註冊時間
2019-8-17 
最後登錄
2021-7-22 
7#
發表於 2019-8-27 18:19 | 只看該作者
回復 6# 准提部林


    非常謝謝版主耐心的回復，我會再研究努力精進 :)

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
6#
發表於 2019-8-25 11:17 | 只看該作者
回復 5# lovegowan

用儲存格對照法吧!  速度較慢:
Sub 載入()
Dim xA As Range, xArea As Range, i, j&
Sheets("主表").UsedRange.Offset(3, 0).EntireRow.Delete
Set xA = [主表!C3]  '初始寫入定位格
Application.ScreenUpdating = False
For i = 2 To Sheets.Count
    Set xA = xA(2, 1)  '寫入定位格向下移一格
    xA = "工作表--" & Sheets(i).Name '寫入工作表名稱
    Set xArea = Sheets(i).[D4:L23]  '定位各分表資料區域
    For j = 1 To 20 '由上往下抓[D4:L23]整列, 再由左往右寫入主表
        xA(1, (j - 1) * 9 + 2).Resize(1, 9) = xArea.Rows(j).Value
    Next j
Next
Range([主表!C4], xA(1, 181)).Borders.LineStyle = 1 '加入框線
End Sub

Xl0000498-1.rar (17.2 KB)


=================================

TOP

lovegowan

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
win10 
軟體版本
office 2016 
閱讀權限
10 
註冊時間
2019-8-17 
最後登錄
2021-7-22 
5#
發表於 2019-8-24 18:46 | 只看該作者
回復 3# 准提部林


    非常感謝版主的回覆

因為有點超過我的理解範圍

不知道可否請版主稍微講解

如果日後欄位有增加或者儲存個指定範圍有變動

我可以自行做修改，再次感謝版主的指教

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
4#
發表於 2019-8-24 10:15 | 只看該作者
公式法
C欄輸入工作表名稱
D4:
=INDEX(INDIRECT("'"&$C4&"'!D4:L23"),COUNTA($D$2:D$2),D$3)
或
=INDEX(INDIRECT("'"&$C4&"'!D4:L23"),INT(COLUMN(I1)/9),D$3)
或
=VLOOKUP(LOOKUP("龥",$D$2:D$2),INDIRECT("'"&$C4&"'!B:L"),D$3+2,)

右拉/下拉


=============================

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
3#
發表於 2019-8-24 10:00 | 只看該作者
各個分表都是固定格式,
Sub 載入()
Dim Arr, A, Sc%, N%, i&, j&
ActiveSheet.UsedRange.Offset(3, 0).EntireRow.Delete
Sc = Sheets.Count - 1
ReDim Arr(1 To Sc, 1 To 181)
For i = 2 To Sheets.Count
    Arr(i - 1, 1) = Sheets(i).Name
    For j = 1 To 180
        Arr(i - 1, j + 1) = Sheets(i).[D4:L23].Item(j)
    Next j
Next
[C4].Resize(Sc, 181) = Arr
End Sub

Xl0000498.rar (16.52 KB)


===================================

TOP

lovegowan

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
win10 
軟體版本
office 2016 
閱讀權限
10 
註冊時間
2019-8-17 
最後登錄
2021-7-22 
2#
發表於 2019-8-23 13:11 | 只看該作者
補充：目前只知道可以這麼寫
Sub 複製貼上()
Worksheets("1").Range("F30:N30").Copy _
Worksheets("sheet1").Range("B3")
Worksheets("1").Range("F31:N31").Copy _
Worksheets("sheet1").Range("K3")
Worksheets("1").Range("F32:N32").Copy _
Worksheets("sheet1").Range("T3")
Worksheets("1").Range("F33:N33").Copy _
Worksheets("sheet1").Range("AC3")
.
.
.
End Sub
以此類推，但因為工作表過多，不太可能把每個"1"改成"2"或"3"....
請教該用什麼迴圈來簡化重複的動作....感謝

TOP

        靜思自在 : 成功是優點的發揮，失敗是缺點的累積。
返回列表 上一主題