關於寫巨集程式自動篩選判斷區的代碼複製成該代碼單獨活頁簿
- 帖子
- 44
- 主題
- 14
- 精華
- 0
- 積分
- 58
- 點名
- 0
- 作業系統
- Window 8
- 軟體版本
- 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-8-15
- 最後登錄
- 2017-4-18
|
關於寫巨集程式自動篩選判斷區的代碼複製成該代碼單獨活頁簿
各位大大好, 範例如附件
說明一下
有一個彙總表的活頁簿，小的想要透過巨集自動分門別類到各自的活頁簿。
PS.附件中，A,B,C的活頁簿是執行巨集後，產生出來的結果。
謝謝各位。 |
-
-
範例.rar
(7.54 KB)
|
|
|
|
|
|
|
- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
2#
發表於 2016-2-19 16:05
| 只看該作者
試試看:- '請貼到 "彙總表"
- Sub 彙入總表()
- Dim sh1 As Worksheet, sh2 As Worksheet
- Dim Lst1 As Integer, Lst2 As Integer
- Dim I As Integer, J As Integer
- Set sh1 = Sheets("彙總表")
- For J = 1 To Sheets.Count
- If Sheets(J).Name <> "彙總表" Then
- Set sh2 = Sheets(J)
- Lst1 = sh1.[B65536].End(xlUp).Row
- Lst2 = sh2.[B65536].End(xlUp).Row
- For I = 5 To Lst2
- sh2.Cells(I, 2).Resize(1, 4).Copy sh1.Cells(Lst1 + I - 4, 2)
- Next
- End If
- Next
- End Sub
|
|
|
|
|
|
|
|
- 帖子
- 44
- 主題
- 14
- 精華
- 0
- 積分
- 58
- 點名
- 0
- 作業系統
- Window 8
- 軟體版本
- 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-8-15
- 最後登錄
- 2017-4-18
|
3#
發表於 2016-2-19 16:46
| 只看該作者
|
to yen956 大大，我執行後，無反應說，我已貼到彙總表的巨集內。 |
|
|
|
|
|
|
|
- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
4#
發表於 2016-2-19 17:37
| 只看該作者
回復 3# 學到老死
以下操作係以 2003為例
你的版本請自行參考：
1. 按 Alt+F11
2. Double Click sheet("彙總表")
3. 貼上 VBA Code
4. 點巨集 Sub()…end
5. 按 F5
|
|
|
|
|
|
|
|
- 帖子
- 44
- 主題
- 14
- 精華
- 0
- 積分
- 58
- 點名
- 0
- 作業系統
- Window 8
- 軟體版本
- 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-8-15
- 最後登錄
- 2017-4-18
|
5#
發表於 2016-2-19 18:32
| 只看該作者
|
yen956大大 感謝 我成功的執行了巨集，但是寫反了@o@ 我想要的是彙總表的資料自動分類成A,B,C...... ~O~ |
|
|
|
|
|
|
|
- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
6#
發表於 2016-2-19 19:39
| 只看該作者
回復 5# 學到老死
'彙出到分頁
'先決條件:"彙總表"欄B中的sheets必須存在
Sub 彙出到分頁()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim Lst1 As Integer, Lst2 As Integer
Dim I As Integer, J As Integer, shName As String
Set sh1 = Sheets("彙總表")
Lst1 = sh1.[B65536].End(xlUp).Row
For I = 5 To Lst1
shName = sh1.Cells(I, 2)
For J = 1 To Sheets.Count
If Sheets(J).Name = shName Then
Lst2 = Sheets(J).[B65536].End(xlUp).Row + 1
If Lst2 < 5 Then Lst2 = 5
sh1.Cells(I, 2).Resize(1, 4).Copy Sheets(J).Cells(Lst2, 2)
Exit For
End If
Next
Next
End Sub |
|
|
|
|
|
|
|
- 帖子
- 2035
- 主題
- 24
- 精華
- 0
- 積分
- 2031
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office2010
- 閱讀權限
- 100
- 性別
- 男
- 註冊時間
- 2012-3-22
- 最後登錄
- 2024-2-1
|
7#
發表於 2016-2-20 08:56
| 只看該作者
回復 5# 學到老死
套用 yen956 大大的現成程式：- ' 請貼到 "彙總表"
- Sub 彙入總表()
- Dim sh1 As Worksheet, sh2 As Worksheet
- Dim Lst1 As Integer
- Dim J As Integer
-
- Set sh1 = Sheets("彙總表")
- sh1.Cells.Clear
-
- For J = 1 To Sheets.Count
- If Sheets(J).Name <> "彙總表" Then
- Set sh2 = Sheets(J)
- Lst1 = sh1.[B65536].End(xlUp).Row + 1
- ' sh2.UsedRange.Address = "$B$4:$E$7" : String
- ' sh2.UsedRange.Offset(1, 0).Address = "$B$5:$E$8" : String
- sh2.UsedRange.Offset(1, 0).Copy sh1.Cells(Lst1, 2)
- End If
- Next
- End Sub
|
|
|
|
|
|
|
|
- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
8#
發表於 2016-2-20 09:25
| 只看該作者
本帖最後由 yen956 於 2016-2-20 09:26 編輯
回復 7# c_c_lai
謝謝c大的指導!!
改用c大的 UsedRange 可批次貼上, 果然簡捷多了, 謝謝指正!! |
|
|
|
|
|
|
|
- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
9#
發表於 2016-2-20 11:10
| 只看該作者
'若資料龐大, 彙出資料到分頁, 可改用本VBA, 會快很多
'先決條件:"彙總表"欄B中的工作表名稱的sheets必須存在
'且已按工作表名稱排序
Sub 彙出到分頁2()
Dim sh1 As Worksheet
Dim Lst1 As Integer, shNameCnt As Integer
Dim I As Integer
Set sh1 = Sheets("彙總表")
Lst1 = sh1.[B65536].End(xlUp).Row
I = 5
Do
shName = sh1.Cells(I, 2)
sh1.[C3].FormulaR1C1 = "=COUNTIF(C[-1],""=""&R" & I & "C[-1])" '計算同名的工作表有幾個
sh1.Cells(I, 2).Resize(sh1.[C3], 4).Copy Sheets(shName).[B5] '批次複製
I = I + sh1.[C3]
Loop Until I > Lst1
End Sub |
|
|
|
|
|
|
|
- 帖子
- 44
- 主題
- 14
- 精華
- 0
- 積分
- 58
- 點名
- 0
- 作業系統
- Window 8
- 軟體版本
- 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-8-15
- 最後登錄
- 2017-4-18
|
10#
發表於 2016-2-20 17:09
| 只看該作者
|
~小的感謝兩位大大 指點 持續鑽研VBA的精華所在 能力上還在初學期，加倍努力中! |
|
|
|
|
|
|
|
