PJChen

　暱稱: PJ

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2013-4-26 17:49 | 只看該作者

[發問] 以A2儲存格為檔名,做成小計報表

有些步驟無法用錄製方式,請大大們幫忙!!
需要執行巨集的報表可能有數個,所以我希望將檔案名稱直接標示在A2.

巨集執行的步驟為:
1- a.xlsx已事先開啟,copy(新增) 報表.sheet後,將它變成沒有任何公式,存檔為:抽水機數據分析_值.xlsx,(為了上傳檔案不要太大,所以事先將a.xlsx變成只有值)
2- 關閉原a.xlsx並且不要存檔.
3- 刪除抽水機數據分析_值 A:C (運作次數(全) /1啟動 /2啟動 )
2- 以"連續日期 "執行分組小計",加總的欄位是"用電度數" and "使用時間(分)".
3- 刪除A欄:連續日期
4- 點選小計選項2 ActiveSheet.Outline.ShowLevels RowLevels:=2 '小計後選#2
5- 希望完成後的報表,我另放在"完成後的報表.sheet"中.
6. 報表.sheet的資料每次都不相同,當然有可能增加筆數,用錄製的無法因應每次不同筆數的作業.

抽水機數據分析報表.zip (30.09 KB)

樓主熱帖

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

16^#

發表於 2013-5-1 10:25 | 只看該作者

回復 15# Hsieh

感謝大人,執行無誤!!

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 277
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

15^#

發表於 2013-5-1 10:09 | 只看該作者

回復 14# PJChen
程式碼都有註解，請了解程式碼就能自行更改

Sub Ex()
Dim A As Range
fs = ThisWorkbook.Sheets("VBA").[A2] 'A2為檔名
With Workbooks(fs)
.Sheets("報表").UsedRange = .Sheets("報表").UsedRange.Value
.Sheets("報表").Copy '把報表複製到新檔案
.Close 0 '關閉a.xlsx
End With
Application.DisplayAlerts = False '關閉對話方塊
ActiveWorkbook.SaveAs "D:\抽水機數據分析_值.xlsx" '將新檔儲存
With Workbooks("抽水機數據分析_值.xlsx") '報表新檔案
With .Sheets("報表")
.UsedRange = .UsedRange.Value '去除公式
.Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(10, 11), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True '已連續日期分組小計
.[A:D].Delete '刪除A:D欄位
If .[B3] = "" Then .Rows(3).Delete
With .Range("F:F").SpecialCells(xlCellTypeFormulas)
.Offset(, -1) = "計"
For Each A In .Cells '畫框線
A = Round(A, 3) '四捨五入小數點3位
A.Offset(, 1) = Round(A.Offset(, 1), 3) '四捨五入小數點3位
For i = 7 To 10
A.Offset(, -1).Resize(, 3).Borders(i).Weight = xlThick '框線寬度
A.Offset(, -1).Resize(, 3).Borders(i).ColorIndex = 3 '框線顏色
Next
Next
End With
For i = 1 To .Cells(.Rows.Count, "E").End(xlUp).CurrentRegion.Rows.Count '總計表格畫框線
For j = 7 To 10
With .Cells(.Rows.Count, "E").End(xlUp).CurrentRegion.Rows(i).Borders(j)
.Weight = xlThick
.ColorIndex = 3
End With
Next
Next
End With
.Save
End With
Application.DisplayAlerts = True
End Sub

複製代碼

學海無涯_不恥下問

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

14^#

發表於 2013-5-1 09:18 | 只看該作者

回復 11# Hsieh

大大,
勞煩您幫忙改個小地方,在最後欄位的小計及總計會出現黑線,可否改成以下的樣式? 謝謝!!
最後的小計.jpg

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

13^#

發表於 2013-5-1 01:45 | 只看該作者

回復 11# Hsieh

大大,
麻煩您很多,不要再改了.
我想改為四捨五入小數第三位,這樣就不會有不符的情形了.

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

12^#

發表於 2013-5-1 01:18 | 只看該作者

回復 11# Hsieh

大大,
我測試後發現四捨五入後小計與總計會有小數差,不知要如何解決?

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 277
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

11^#

發表於 2013-5-1 00:48 | 只看該作者

回復 10# PJChen

Sub Ex()
Dim A As Range
fs = ThisWorkbook.Sheets("VBA").[A2] 'A2為檔名
With Workbooks(fs)
.Sheets("報表").UsedRange = .Sheets("報表").UsedRange.Value
.Sheets("報表").Copy '把報表複製到新檔案
.Close 0 '關閉a.xlsx
End With
Application.DisplayAlerts = False '關閉對話方塊
ActiveWorkbook.SaveAs "D:\抽水機數據分析_值.xlsx" '將新檔儲存
With Workbooks("抽水機數據分析_值.xlsx") '報表新檔案
With .Sheets("報表")
.UsedRange = .UsedRange.Value '去除公式
.Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(10, 11), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True '已連續日期分組小計
.[A:D].Delete '刪除A:D欄位
If .[B3] = "" Then .Rows(3).Delete
With .Range("F:F").SpecialCells(xlCellTypeFormulas)
.Offset(, -1) = "計"
For Each A In .Cells '畫框線
A = Round(A, 2) '四捨五入
A.Offset(, 1) = Round(A.Offset(, 1), 2) '四捨五入
For i = 7 To 10
A.Offset(, -1).Resize(, 3).Borders(i).Weight = xlThick '框線寬度
A.Offset(, -1).Resize(, 3).Borders(i).ColorIndex = 3 '框線顏色
Next
Next
End With
End With
.Save
End With
Application.DisplayAlerts = True
End Sub

複製代碼

學海無涯_不恥下問

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

10^#

發表於 2013-5-1 00:33 | 只看該作者

回復 8# Hsieh

不好意思,除了前面二項,又發現另一個問題.
3) 原來的報表.sheet是有公式及連結的,為了方便上傳,所以公式差不多都去除了,在存檔前要先把公式變成值(否則全都錯誤值),是否加在這句之後?
可是它說是"錯誤的引用",我改怎麼改?

Workbooks(fs).Sheets("報表").Copy '把報表複製到新檔案
.UsedRange = .UsedRange.Value '去除公式

複製代碼

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

9^#

發表於 2013-5-1 00:12 | 只看該作者

回復 8# Hsieh

大大,
1)  跑到這行就中止了,因為A2的儲存格可以用任意檔名,檔名不是"a.xlsx"時,它就無法繼續了,改成以下請問差別在哪兒?
Workbooks("a.xlsx").Close 0 '關閉a.xlsx....改為Workbooks(fs).Close 0 '關閉a.xlsx  >>ok
                                                                        ....改為Workbooks("fs").Close 0 '關閉a.xlsx  >>不行
2) 若小計&總計欄位,改為小數後2位四捨五入,請問要在哪行更改?加上什麼程式?

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 277
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

8^#

發表於 2013-4-30 22:43 | 只看該作者

本帖最後由 Hsieh 於 2013-5-1 00:23 編輯

回復 7# PJChen

Sub Ex()
fs = ThisWorkbook.Sheets("VBA").[A2] 'A2為檔名
Workbooks(fs).Sheets("報表").Copy '把報表複製到新檔案
Workbooks(fs).Close 0 '關閉a.xlsx
Application.DisplayAlerts = False '關閉對話方塊
ActiveWorkbook.SaveAs "D:\抽水機數據分析_值.xlsx" '將新檔儲存
With Workbooks("抽水機數據分析_值.xlsx") '報表新檔案
With .Sheets("報表")
.UsedRange = .UsedRange.Value '去除公式
.Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(10, 11), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True '已連續日期分組小計
.[A:D].Delete '刪除A:D欄位
If .[B3] = "" Then .Rows(3).Delete
With .Range("F:F").SpecialCells(xlCellTypeFormulas)
.Offset(, -1) = "計"
For Each A In .Cells '畫框線
For i = 7 To 10
A.Offset(, -1).Resize(, 3).Borders(i).Weight = xlThick '框線寬度
A.Offset(, -1).Resize(, 3).Borders(i).ColorIndex = 3 '框線顏色
Next
Next
End With
.UsedRange = .UsedRange.Value '去除公式
End With
.Save
End With
Application.DisplayAlerts = True
End Sub

複製代碼

學海無涯_不恥下問

TOP