返回列表 上一主題 發帖

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

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2013-4-29 23:30 | 顯示全部帖子
本帖最後由 Hsieh 於 2013-4-29 23:33 編輯

回復 5# PJChen
  1. Sub Ex()
  2. Workbooks("a.xlsx").Sheets("報表").Copy '把報表複製到新檔案
  3. Workbooks("a.xlsx").Close 0 '關閉a.xlsx
  4. Application.DisplayAlerts = False '關閉對話方塊
  5. ActiveWorkbook.SaveAs "D:\抽水機數據分析_值.xlsx" '將新檔儲存
  6. With Workbooks("抽水機數據分析_值.xlsx") '報表新檔案
  7. With .Sheets("報表")
  8. .UsedRange = .UsedRange.Value '去除公式
  9. .Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(10, 11), _
  10.         Replace:=True, PageBreaks:=False, SummaryBelowData:=True '已連續日期分組小計
  11. .[A:D].Delete '刪除A:D欄位
  12. If .[B3] = "" Then .Rows(3).Delete
  13. With .Range("F:F").SpecialCells(xlCellTypeFormulas)
  14. .Offset(, -1) = "計"
  15. For Each A In .Cells '畫框線
  16.    For i = 7 To 10
  17.        A.Offset(, -1).Resize(, 3).Borders(i).Weight = xlMedium
  18.        A.Offset(, -1).Resize(, 3).Borders(i).ColorIndex = 3
  19.    Next
  20. Next
  21. End With
  22. .UsedRange = .UsedRange.Value '去除公式
  23. End With
  24. .Save
  25. End With
  26. Application.DisplayAlerts = True
  27. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2013-4-30 22:43 | 顯示全部帖子
本帖最後由 Hsieh 於 2013-5-1 00:23 編輯

回復 7# PJChen
  1. Sub Ex()
  2. fs = ThisWorkbook.Sheets("VBA").[A2] 'A2為檔名
  3. Workbooks(fs).Sheets("報表").Copy '把報表複製到新檔案
  4. Workbooks(fs).Close 0 '關閉a.xlsx
  5. Application.DisplayAlerts = False '關閉對話方塊
  6. ActiveWorkbook.SaveAs "D:\抽水機數據分析_值.xlsx" '將新檔儲存
  7. With Workbooks("抽水機數據分析_值.xlsx") '報表新檔案
  8. With .Sheets("報表")
  9. .UsedRange = .UsedRange.Value '去除公式
  10. .Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(10, 11), _
  11.         Replace:=True, PageBreaks:=False, SummaryBelowData:=True '已連續日期分組小計
  12. .[A:D].Delete '刪除A:D欄位
  13. If .[B3] = "" Then .Rows(3).Delete
  14. With .Range("F:F").SpecialCells(xlCellTypeFormulas)
  15. .Offset(, -1) = "計"
  16. For Each A In .Cells '畫框線
  17.    For i = 7 To 10
  18.        A.Offset(, -1).Resize(, 3).Borders(i).Weight = xlThick '框線寬度
  19.        A.Offset(, -1).Resize(, 3).Borders(i).ColorIndex = 3 '框線顏色
  20.    Next
  21. Next
  22. End With
  23. .UsedRange = .UsedRange.Value '去除公式
  24. End With
  25. .Save
  26. End With
  27. Application.DisplayAlerts = True
  28. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2013-5-1 00:48 | 顯示全部帖子
回復 10# PJChen
  1. Sub Ex()
  2. Dim A As Range
  3. fs = ThisWorkbook.Sheets("VBA").[A2] 'A2為檔名
  4. With Workbooks(fs)
  5. .Sheets("報表").UsedRange = .Sheets("報表").UsedRange.Value
  6. .Sheets("報表").Copy '把報表複製到新檔案
  7. .Close 0 '關閉a.xlsx
  8. End With
  9. Application.DisplayAlerts = False '關閉對話方塊
  10. ActiveWorkbook.SaveAs "D:\抽水機數據分析_值.xlsx" '將新檔儲存
  11. With Workbooks("抽水機數據分析_值.xlsx") '報表新檔案
  12. With .Sheets("報表")
  13. .UsedRange = .UsedRange.Value '去除公式
  14. .Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(10, 11), _
  15.         Replace:=True, PageBreaks:=False, SummaryBelowData:=True '已連續日期分組小計
  16. .[A:D].Delete '刪除A:D欄位
  17. If .[B3] = "" Then .Rows(3).Delete
  18. With .Range("F:F").SpecialCells(xlCellTypeFormulas)
  19. .Offset(, -1) = "計"
  20. For Each A In .Cells '畫框線
  21. A = Round(A, 2) '四捨五入
  22. A.Offset(, 1) = Round(A.Offset(, 1), 2) '四捨五入
  23.    For i = 7 To 10
  24.        A.Offset(, -1).Resize(, 3).Borders(i).Weight = xlThick '框線寬度
  25.        A.Offset(, -1).Resize(, 3).Borders(i).ColorIndex = 3 '框線顏色
  26.    Next
  27. Next
  28. End With
  29. End With
  30. .Save
  31. End With
  32. Application.DisplayAlerts = True
  33. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2013-5-1 10:09 | 顯示全部帖子
回復 14# PJChen
程式碼都有註解，請了解程式碼就能自行更改
  1. Sub Ex()
  2. Dim A As Range
  3. fs = ThisWorkbook.Sheets("VBA").[A2] 'A2為檔名
  4. With Workbooks(fs)
  5. .Sheets("報表").UsedRange = .Sheets("報表").UsedRange.Value
  6. .Sheets("報表").Copy '把報表複製到新檔案
  7. .Close 0 '關閉a.xlsx
  8. End With
  9. Application.DisplayAlerts = False '關閉對話方塊
  10. ActiveWorkbook.SaveAs "D:\抽水機數據分析_值.xlsx" '將新檔儲存
  11. With Workbooks("抽水機數據分析_值.xlsx") '報表新檔案
  12. With .Sheets("報表")
  13. .UsedRange = .UsedRange.Value '去除公式
  14. .Range("A1").CurrentRegion.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(10, 11), _
  15.         Replace:=True, PageBreaks:=False, SummaryBelowData:=True '已連續日期分組小計
  16. .[A:D].Delete '刪除A:D欄位
  17. If .[B3] = "" Then .Rows(3).Delete
  18. With .Range("F:F").SpecialCells(xlCellTypeFormulas)
  19. .Offset(, -1) = "計"
  20. For Each A In .Cells '畫框線
  21. A = Round(A, 3) '四捨五入小數點3位
  22. A.Offset(, 1) = Round(A.Offset(, 1), 3) '四捨五入小數點3位
  23.    For i = 7 To 10
  24.        A.Offset(, -1).Resize(, 3).Borders(i).Weight = xlThick '框線寬度
  25.        A.Offset(, -1).Resize(, 3).Borders(i).ColorIndex = 3 '框線顏色
  26.    Next
  27. Next
  28. End With
  29. For i = 1 To .Cells(.Rows.Count, "E").End(xlUp).CurrentRegion.Rows.Count '總計表格畫框線
  30.     For j = 7 To 10
  31.        With .Cells(.Rows.Count, "E").End(xlUp).CurrentRegion.Rows(i).Borders(j)
  32.           .Weight = xlThick
  33.           .ColorIndex = 3
  34.         End With
  35.     Next
  36. Next
  37. End With
  38. .Save
  39. End With
  40. Application.DisplayAlerts = True
  41. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 君子立恆志，小人恆立志。
返回列表 上一主題