帖子: 15
主題: 2
精華: 0
積分: 23
點名: 0
作業系統: windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台中
註冊時間: 2016-9-22
最後登錄: 2021-3-26

論壇贊助勳章

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2016-10-3 14:34 | 只看該作者

[發問] 請問如何把無資料的多餘頁面設定一按鈕刪除

各位前輩好~

如附加檔案，預設有61頁(因上傳不了，減成10頁)，但因用途，有時用不了那麼多，
有沒有VBA能寫成：若沒用到的頁面無資料(沒用到的頁面)，按鈕就自動刪除的方法？

因為一個workbook常有好幾個 sheets，一個sheet約1.5MB, 四個sheet 就6MB, 檔案實在太大了…

反過來說，如果我預設20頁，不夠用時，能否也新增一vba按鈕, 一按就能在sheet最下面直接新增一新頁，
且右方"灰色區域"的總計連結也能統計到？

請大家幫忙一下了~~真心感謝

WB.ver06.xlsm.zip (268.31 KB)

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

24^#

發表於 2022-12-13 15:50 | 只看該作者

回復 23# Andy2483

複習&再檢查修改程式碼註解如下:

Option Explicit
Sub TEST()
Dim Brr, Y, C&, i&, j&, R&, N&, Sh As Worksheet
'↑宣告變數:(Brr, Y)是通用型,(C,i,j,R,N)是長整數,(Sh)是工作表
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y 是字典
Set Sh = ActiveSheet: N = 15
'↑令Sh 是現用工作表: 令N=15
Brr = Range(Sh.[A1], Sh.Cells(Sh.UsedRange.Rows.Count, "AM"))
'↑令Brr是二維陣列!倒入[A1]到(AM欄/最後有使用的儲存格那一列的列號儲存格) 值
For i = 1 To 39
'↑設順迴圈!i從 1到39
Y(i & "C") = Columns(i).ColumnWidth
'↑令迴圈數連接"C"當key,item是迴圈數欄位的欄寬
Y(i & "R") = Rows(i).Rows.RowHeight
'↑令迴圈數連接"R"當key,item是迴圈數列位的列高
Next
For i = 16 To UBound(Brr)
'↑設外順迴圈!i從 16到Brr陣列縱向最大列號數
If IsNumeric(Brr(i, 37)) And Brr(i, 37) <> "" Then
'↑如果IsNumeric()函數判斷迴圈列第37欄Brr陣列值是數字,且不是空字元
   N = N + 1
   '↑N數字變數累加 1
   For j = 1 To 39
   '↑設內順迴圈!j從 1到39
      Brr(N, j) = Brr(i, j)
      '↑令N變數列第j迴圈欄的Brr陣列值是 i變數列第j迴圈欄的Brr陣列值
   Next
End If
Next
Set Y("表頭") = Range(Sh.[A1], Sh.[AM16])
'↑令以 "表頭"字串為key,item是現用工作表[A1]到[AM16]儲存格集,倒入Y字典裡
'在開一個新活頁簿之前把用得到的資料用字典與陣列裝起來
'Y("表頭")儲存格裡有公式!
Workbooks.Add
'↑開一個新活頁簿
Y("表頭").Copy [A1]
'↑令以 "表頭"字串查Y字典,把儲存格集複製到此新活頁簿[A1]
For i = 1 To 39
'↑設順迴圈!i從 1到39
Columns(i).ColumnWidth = Y(i & "C")
'↑以i迴圈數連接"C"的字串查Y字典的item值為i迴圈數欄欄寬
Rows(i).Rows.RowHeight = Y(i & "R")
'↑以i迴圈數連接"R"的字串查Y字典的item值為i迴圈數列列高
Next
Range([A16], [AM16]).ClearContents
'↑[A16]到[AM16]儲存格內容清空
Range([A16], [AM16]).Borders.LineStyle = 1
'↑[A16]到[AM16]儲存格格線是細實線
[16:16].Copy Rows("17:" & N)
'↑第16列複製到 17至 N變數列
[A1].Resize(N, 39) = Brr
'↑令[A1]擴展向下N變數列,向右擴展39欄範圍的儲存格,以Brr陣列值倒入
'Y("表頭")儲存格裡有公式!所以需要以陣列值帶入
Set Brr = Nothing
Set Y = Nothing
'↑釋放變數
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

23^#

發表於 2022-12-12 16:44 | 只看該作者

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列&字典
結果:

Option Explicit
Sub TEST()
Dim Brr, Crr, C&, i&, j&, xR, R&, T, V, Y, Z
Dim N&, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = ActiveSheet
Brr = Range(Sh.[A1], Sh.Cells(Sh.UsedRange.Rows.Count, "AM"))
For i = 1 To [AM1].Column
Y(i & "C") = Columns(i).ColumnWidth
Next
For i = 1 To 15
Y(i & "R") = Rows(i).Rows.RowHeight
Next
For i = 16 To UBound(Brr)
If IsNumeric(Brr(i, [AK1].Column)) And Brr(i, [AK1].Column) <> "" Then
   N = N + 1
   For j = 1 To [AM1].Column
      Brr(N, j) = Brr(i, j)
   Next
End If
Next
Set Y("表頭") = Range(Sh.[A1], Sh.[AM16])
Workbooks.Add
Y("表頭").Copy [A1]
For i = 1 To [AM1].Column
Columns(i).ColumnWidth = Y(i & "C")
Next
For i = 1 To 15
Rows(i).Rows.RowHeight = Y(i & "R")
Next
Range([A16], [AM16]).ClearContents
Range([A16], [AM16]).Borders.LineStyle = 1
[16:16].Copy Rows("17:" & N + 15)
[A16].Resize(N, [AM1].Column) = Brr
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

22^#

發表於 2022-12-12 15:19 | 只看該作者

回復 14# 准提部林

謝謝 simplehope前輩發表此主題與範例
謝謝准提部林前輩指導
後學在此帖學到很多知識,心得註解如下,請再指導,謝謝

Option Explicit
Sub 匯出地磅資料到新工作表()
Dim vSht As Worksheet, R&, vR As Range, SHN$, xSht As Worksheet
'↑宣告(vSht,xSht) 是工作表,(R)是長整數,(vR)是儲存格,(SHN)是字串
Set vSht = ActiveSheet
'↑令vSht是現用工作表
SHN = vSht.Name & "匯出"
'↑令SHN字串變數是vSht工作表名字連接 "匯出"的字串
On Error Resume Next
'↑指定當發生執行階段錯誤時，control 會移至緊接在發生錯誤且繼續執行的語句後面的語句。
'https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/on-error-statement
Set xSht = Sheets(SHN)
'↑令xSht是名為 SHN變數字串的工作表
On Error GoTo 0
'↑停用目前過程中已啟用的任何錯誤處理常式。
If xSht Is Nothing Then
'↑如果xSht變數判定是Nothing(沒有物件)
Set xSht = Sheets.Add(after:=Sheets(Sheets.Count))
'↑令xSht是在最後一個工作表後面新增一個的工作表
'Sheets(Sheets.Count):最後一個工作
End If
With xSht
'↑以下是關於xSht變數工作表的程序
   .Name = SHN
   '↑重命名是 SHN
   .Cells.Clear
   '↑清除全部儲存格
   .[BK3] = vSht.[BK3].Value
   '↑令[BK3]值是現用工作表[BK3]值
   .[AV1] = vSht.[AV1].Value
   '↑令[AV1]值是現用工作表[AV1]值
   .[BI3] = vSht.[BI3].Value
   '↑令[BI3]值是現用工作表[BI3]值
   R = Val(vSht.[AT51]) * 52
   '↑令R 是現用工作表[AT51]值轉化為數值
   'Val():傳回字串中包含的數位，做為適當類型的數值。
   If R = 0 Then Exit Sub '取得頁數
   '↑如果R這數字變數是 0,就結束程式執行
   vSht.Range("A1:AM" & R).Copy .[A1] '貼上資料
   '↑現用工作表.[A1]到AM欄R列儲存格之間範圍儲存格複製到 xSht變數工作表[A1]
   .Range("A16:A" & R) = "=TEXT(COUNT(AK$16:AK16),""'000"")" '序號公式
   '↑xSht變數工作表[A16]到A欄R列儲存格之間範圍儲存格字串是序號公式
   '公式意義:判定指定儲存格範圍是數字的格數轉化為3碼文字,前面再以單引號連接
   'TEXT 函數，以格式代碼來套用格式，藉此變更數字顯示的方式。
   'https://support.microsoft.com/zh-tw/office/text-%E5%87%BD%E6%95%B8-20d5ac4d-7b94-49fd-bb38-93d29371225c
   'COUNT() 函數只會統計數字型的數據資料，若是碰到文字內容的表格也會被忽略。
   '因為儲存格如果是公式!會自動累加其列位.欄位或都累加,視欄列是否冠上"$"符號而定
   .Range("A1:AM" & R) = .Range("A1:AM" & R).Value '全部內容貼成值
   '↑令xSht變數工作表.[A1]到AM欄R列儲存格之間範圍儲存格全部內容貼成值
   For Each vR In vSht.[A1:AM1]
   '↑設順迴圈!令vR儲存格變數是現用工作表裡[A1:AM1]的一格
      .Range(vR.Address).ColumnWidth = vR.ColumnWidth '欄寬
      '↑令xSht變數工作表裡 (vR儲存格變數所在位址)的儲存格欄寬是同vR儲存格變數欄寬
   Next
   .[BK3] = "": .[AV1] = "": .[BI3] = ""
   '↑令xSht變數工作表裡[BK3],[AV1],[BI3]儲存格是空格
End With

On Error Resume Next
'↑遇錯繼續執行不偵錯
With xSht.Range("AK16:AK" & R)
'↑以下是關於xSht變數工作表 [AK16]到AK欄R列儲存格之間範圍儲存格的程序
   .SpecialCells(xlCellTypeConstants, 22).EntireRow.Delete '刪除〔文字〕格整列
   '↑判定xlErrors(單元錯誤值) Or xlLogical(具有邏輯值的單元格) Or xlTextValues(具有文字的儲存格)
   '範圍裡這幾種值的儲存格所在的列刪除
   'https://learn.microsoft.com/zh-tw/office/vba/api/excel.xlspecialcellsvalue
   .SpecialCells(xlCellTypeBlanks).EntireRow.Delete  '刪除〔空白格〕整列
   '範圍裡空格儲存格所在的列刪除,(不包含有公式結果為空白字元的儲存格)
End With
On Error GoTo 0
'↑停用目前過程中已啟用的任何錯誤處理常式。
xSht.Select
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

21^#

發表於 2016-10-9 20:15 | 只看該作者

本帖最後由准提部林於 2016-10-9 20:18 編輯

回復 18# simplehope

您第一次是公式原盤貼過來，再貼成值，這就是參照遺失問題，
將原表ＡＶ１改成〔卸櫃〕，再執行您原來程式，
手工去比對兩表Ｎ／Ｐ兩欄計算結果看看！！！

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

20^#

發表於 2016-10-9 20:10 | 只看該作者

回復 16# simplehope

公式參照並未帶工作表名稱引數，
因此貼至其它表時，它參照的是本身表的儲存格，
但這表的參照格是空白的，公式值當然是錯誤的！

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

19^#

發表於 2016-10-9 20:03 | 只看該作者

本帖最後由准提部林於 2016-10-9 20:05 編輯

回復 15# simplehope

.SpecialCells(xlCellTypeConstants, 22).EntireRow.Delete '刪除〔文字〕格整列
用的是功能表：編輯＞到＞特殊（其它版本可能不同，找看看）　　

因為AK欄有效內容為〔數值〕，所以只要將〔文字〕及〔空格〕整列拿掉，剩下的就是所需：　

使用〔錄製〕就可以取得程式碼（要錄兩次）！　
　
使用這功能時，若選取範圍中沒有文字及空格，程式會發生錯誤而中斷，
所以前面加個　On Error Resume Next （略過程式錯誤繼續執行），
這是已預知下兩行程式可能有錯誤發生前提下所加的，
當那兩行程式執行完畢，必須讓程式恢復〔偵錯〕的功能，
所以再加　On Error GoTo 0　（恢復偵錯），
否則後面的程式若有錯誤將無從得知，也因此可能處理出來的資料並不正確，而無錯誤提示，
上一段的：
On Error Resume Next
Set xSht = Sheets(SHN)　＞　若工作表不存在，預設將提示錯誤，此時提示就略過了
On Error GoTo 0
　
　

TOP

simplehope

小學生 Rank: 1

帖子: 15
主題: 2
精華: 0
積分: 23
點名: 0
作業系統: windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台中
註冊時間: 2016-9-22
最後登錄: 2021-3-26

論壇贊助勳章

18^#

發表於 2016-10-9 18:59 | 只看該作者

回復 17# simplehope

疑問用小弟原本的程式碼會不會有這問題，
回頭看才發現，原來是我貼上兩次…第一次直接paste, 第二次貼上值&格式，所以才沒出現缺乏參照的問頭
…真是土炮+瞎貓碰上死秏子…

TOP

simplehope

小學生 Rank: 1

帖子: 15
主題: 2
精華: 0
積分: 23
點名: 0
作業系統: windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台中
註冊時間: 2016-9-22
最後登錄: 2021-3-26

論壇贊助勳章

17^#

發表於 2016-10-9 18:46 | 只看該作者

回復 16# simplehope

試著手動copy 範圍，再貼到新工作表，
就發現內容中有公式的格子都沒資料，因為缺乏參照…
好像知道為什麼了…
能發現這也太神

TOP

simplehope

小學生 Rank: 1

帖子: 15
主題: 2
精華: 0
積分: 23
點名: 0
作業系統: windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台中
註冊時間: 2016-9-22
最後登錄: 2021-3-26

論壇贊助勳章

16^#

發表於 2016-10-9 18:37 | 只看該作者

回復 14# 准提部林

慚愧…小弟也沒發覺…
搞不懂，為何沒修正之前，一樣是copy , vSht.Range("A1:AM" & R).Copy .[A1] '貼上資料
照理來說應該會一五一十把Range("A1:AM" & R)的內容copy 過去，
但換了[AV1]下拉選單的項目，卻還是copy 沒換之前的內容？
小弟不懂，能說明一下原因嗎？

With xSht
   .Name = SHN:  .Cells.Clear '重命名, 清除內容
   .[BK3] = vSht.[BK3].Value
   .[AV1] = vSht.[AV1].Value
   .[BI3] = vSht.[BI3].Value
   R = Val(vSht.[AT51]) * 52: If R = 0 Then Exit Sub '取得頁數
   vSht.Range("A1:AM" & R).Copy .[A1] '貼上資料
   .Range("A16:A" & R) = "=TEXT(COUNT(AK$16:AK16),""'000"")" '序號公式
   .Range("A1:AM" & R) = .Range("A1:AM" & R).Value '全部內容貼成值
   For Each vR In vSht.[A1:AM1]
      .Range(vR.Address).ColumnWidth = vR.ColumnWidth '欄寬
   Next
   .[BK3] = "": .[AV1] = "": .[BI3] = ""
End With

TOP

[發問] 請問如何把無資料的多餘頁面設定一按鈕刪除

[發問] 請問如何把無資料的多餘頁面設定一按鈕刪除

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]