Board logo

標題: [發問] 以A2儲存格為檔名,做成小計報表 [打印本頁]
作者: PJChen    時間: 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的資料每次都不相同,當然有可能增加筆數,用錄製的無法因應每次不同筆數的作業.

[attach]14796[/attach]
作者: stillfish00    時間: 2013-4-26 20:49

本帖最後由 stillfish00 於 2013-4-26 20:52 編輯

6不太懂 , 你試看看還有什麼問題
  1. Sub paper2()
  2.     Workbooks(ThisWorkbook.Sheets("VBA").[A2].Value).Sheets("報表").Range("D:K").Copy   '複製D欄到K欄
  3.    
  4.     With Workbooks.Add  '新增一空白活頁簿
  5.         With .Sheets(1)
  6.             .Name = "報表"
  7.             .[A1].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False  '貼上值
  8.             .[A1].PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False  '貼上來源格式
  9.             
  10.             '小計
  11.             .[A2].Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(7, 8), _
  12.                     Replace:=True, PageBreaks:=False, SummaryBelowData:=True
  13.             
  14.             .[A:A].Delete Shift:=xlToLeft       '小計後刪除A欄
  15.             .Outline.ShowLevels RowLevels:=2    '小計後選#2
  16.         End With
  17.         .SaveAs "D:\抽水機數據分析報表\抽水機數據分析_值.xlsx"  '儲存檔案
  18.         .Close
  19.     End With
  20.    
  21.     '關閉檔案
  22.     Workbooks(ThisWorkbook.Sheets("VBA").[A2].Value).Close False
  23.     ThisWorkbook.Close False
  24. End Sub
複製代碼
回復 1# PJChen
作者: PJChen    時間: 2013-4-26 23:08

回復 2# stillfish00

您好,

巨集雖可執行,但有以下不符,請再幫忙查看.
1.  原a.xlsx的報表.sheet為一個格式已設定好的報表,希望可以將原檔copy成新的,較方便作業.
2.  新的檔  抽水機數據分析_值.xlsx,無法將公式變成值,我測試了下,還是有公式. 如: 抽水機數據分析_值.zip     [attach]14797[/attach]
3.  我想要完成後的檔案如: 完成後的報表.zip      [attach]14798[/attach]
作者: stillfish00    時間: 2013-4-29 10:07

  1. Sub paper2()
  2.     With Workbooks(ThisWorkbook.Sheets("VBA").[A2].Value).Sheets("報表")
  3.         .UsedRange.Value = .UsedRange.Value    '改為值
  4.         .Range("A:C").Delete Shift:=xlToLeft   '刪除A:C
  5.         
  6.         '小計
  7.         .[A2].Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(7, 8), _
  8.                 Replace:=True, PageBreaks:=False, SummaryBelowData:=True
  9.         .[A:A].Delete Shift:=xlToLeft       '小計後刪除A欄
  10.         .Outline.ShowLevels RowLevels:=2    '小計後選#2
  11.         .SaveAs "D:\抽水機數據分析報表\抽水機數據分析_值.xlsx"  '儲存檔案
  12.         .Parent.Close False
  13.     End With
  14.    
  15.     '關閉報表程式
  16.     ThisWorkbook.Close False
  17. End Sub
複製代碼
回復 3# PJChen
作者: PJChen    時間: 2013-4-29 22:21

回復 4# stillfish00

您好,

第2次的修改已經可以將另存的 抽水機數據分析_值.xlsx檔案內容改為值,但它依無法完全像 "完成後的報表.zip" 同格式(包含框線),因為這部份無法用錄製的(因為報表資料會變化),如果有人知道怎麼寫後續的程式的話,是否可以幫幫忙?

我想讓小計完成後 點選小計2        .Outline.ShowLevels RowLevels:=2, 將可見儲存格劃紅色粗框線(詳見: "完成後的報表.zip" )
作者: Hsieh    時間: 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
複製代碼
作者: PJChen    時間: 2013-4-30 22:02

回復 6# Hsieh

大大,

感謝你再次的幫忙.
出現了點小問題,因為每個報表要區分各種不同的抽水機,所有會有各式各樣的檔名,我想延用最初的概念,將檔名設在以下的A2儲存格中,
1)  請問在你寫的程式中,我要怎麼將以下的句子套進程式中?
    With Workbooks(ThisWorkbook.Sheets("VBA").[A2].Value).Sheets("報表")
2) 我想將線改成最粗的線,是否改這句?應該怎麼改?     For Each A In .Cells '畫框線
作者: Hsieh    時間: 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
複製代碼
作者: PJChen    時間: 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位四捨五入,請問要在哪行更改?加上什麼程式?
作者: PJChen    時間: 2013-5-1 00:33

回復 8# Hsieh

不好意思,除了前面二項,又發現另一個問題.
3) 原來的報表.sheet是有公式及連結的,為了方便上傳,所以公式差不多都去除了,在存檔前要先把公式變成值(否則全都錯誤值),是否加在這句之後?
可是它說是"錯誤的引用",我改怎麼改?
  1. Workbooks(fs).Sheets("報表").Copy '把報表複製到新檔案
  2. .UsedRange = .UsedRange.Value '去除公式
複製代碼
作者: Hsieh    時間: 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
複製代碼
作者: PJChen    時間: 2013-5-1 01:18

回復 11# Hsieh

大大,
我測試後發現 四捨五入後 小計與總計會有小數差,不知要如何解決?
作者: PJChen    時間: 2013-5-1 01:45

回復 11# Hsieh

大大,
麻煩您很多,不要再改了.
我想改為四捨五入小數第三位,這樣就不會有不符的情形了.
作者: PJChen    時間: 2013-5-1 09:18

回復 11# Hsieh

大大,
勞煩您幫忙改個小地方,在最後欄位的小計及總計會出現黑線,可否改成以下的樣式? 謝謝!!
[attach]14839[/attach]
作者: Hsieh    時間: 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
複製代碼
作者: PJChen    時間: 2013-5-1 10:25

回復 15# Hsieh

感謝大人,執行無誤!!



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