Board logo

標題: [發問] 請問如何把無資料的多餘頁面設定一按鈕刪除 [打印本頁]
作者: simplehope    時間: 2016-10-3 14:34     標題: 請問如何把無資料的多餘頁面設定一按鈕刪除

各位前輩好~

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

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

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

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

[attach]25425[/attach]
作者: simplehope    時間: 2016-10-3 20:07

下午突然想到以下寫法：
===========
Sub 刪除空白頁面()

For i = 3128 To 112 Step -52

    If Range("AH" & i) = "" Then
    Range("AH" & i).Offset(-7, 0).Rows("1:52").EntireRow.Select
    Selection.Delete Shift:=xlUp

    End If

Next

End Sub
====================
但執行後，總頁數會亂掉，如圖：
[attach]25432[/attach]
總頁數61頁，但實際只有二頁

[attach]25433[/attach]
連接頁數的灰色區域

應該是cell AT74要改公式，但想不出來可以用什麼函數。
只好再請大俠們幫幫忙~~
作者: simplehope    時間: 2016-10-3 21:22

抱歉大家，被我矇到，用最笨的方法試出了!
再加問，如果執行後有兩頁，想另存成pdf，如何擷取工作表名稱為pdf 的名稱?
這次我真的不會了....
作者: simplehope    時間: 2016-10-4 12:36

回復 3# simplehope

熬到半夜三點，總算試出來了，新增頁面後，還是會有頁數亂掉的問題。
慢慢研究，也謝謝有進來看的大家。
作者: GBKEE    時間: 2016-10-5 09:04

本帖最後由 GBKEE 於 2016-10-8 15:17 編輯

回復 4# simplehope
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Sh As Worksheet, xCol As Integer, Rng As Range, i As Integer
  4.     For Each Sh In ActiveWorkbook.Sheets
  5.          If Sh.PageSetup.PrintArea <> "" Then
  6.             Set Rng = Nothing
  7.             With Sh
  8.                 xCol = .VPageBreaks(1).Location.Column
  9.                 For i = 1 To .HPageBreaks.Count
  10.                     If .HPageBreaks(i).Location.Range("F16") = "" Then Set Rng = .HPageBreaks(i).Location: Exit For
  11.                 Next
  12.                 If Not Rng Is Nothing Then
  13.                     .PageSetup.PrintArea = .Range("a1", .Cells(Rng.Offset(-1).Row, xCol)).Address
  14.                     .Range("a1", .Cells(Rng.Offset(-1).Row, xCol)).Select
  15.                     .Range(Rng, .Range("A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)).Resize(, xCol).Delete xlUp
  16.                     'AJ欄原本公式=IF(AT14="","",$AT$74) , 改公式 =總頁數
  17.                 End If
  18.             End With
  19.             Sh.Names.Add Name:="總頁數", RefersToR1C1:=Sh.HPageBreaks.Count + 1
  20.         End If
  21.     Next
  22. End Sub
複製代碼
PS:2016/10/08 修正
作者: simplehope    時間: 2016-10-8 00:47

謝謝G大，這夠小弟研究好一陣子了：)
很高級的寫法…小弟的土炮實在慚愧無法相比


跟with •••end with
跟for each...in
跟if not 條件式 真的是很不熟啊…
作者: simplehope    時間: 2016-10-8 10:31

回復 5# GBKEE

G大不好意思，執行到一半會出現錯誤："陣列索引超出範圍"如下圖：
    [attach]25488[/attach]
[attach]25489[/attach]
猜問題出在 xCol = .VPageBreaks(1).Location.Column  但不會改....

對以下這句也不懂：
Range(Rng, .Range("A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)).Resize(, xCol).Delete xlUp
'AJ欄原本公式=IF(AT14="","",$AT$74) , 改公式 =總頁數

還有這句是
Sh.Names.Add Name:="總頁數", RefersToR1C1:=Sh.HPageBreaks.Count + 1
意思是新增一個名稱範圍叫 "總頁數"，取R1C1格式，看有幾個HPageBreak 再+ 1 嗎?
那AJ欄要怎麼連到"總頁數"呢?
腦袋有點轉不過來
作者: GBKEE    時間: 2016-10-8 15:30

本帖最後由 GBKEE 於 2016-10-8 15:31 編輯

回復 7# simplehope

5# 的程式碼已修正,請再試試

'** 取A1到 第一個垂直分頁線的最右邊的欄位)再向下到工作頁的 最後一個儲存格的列號******
Range(Rng, .Range("A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)).Resize(, xCol).Delete xlUp
'AJ欄原本公式=IF(AT14="","",$AT$74) , 改公式 =總頁數
'SpecialCells : expression.SpecialCells(Type, Value)
'SpecialCells 方法    傳回 Range 物件，此物件代表與指定型態及值相符合的所有儲存格。Range 物件
'Type     必選的 XlCellType。要包含的儲存格。
'xlCellTypeLastCell。已用範圍的最後一個儲存格=>工作頁的 最後一個儲存格

還有這句是
Sh.Names.Add Name:="總頁數", RefersToR1C1:=Sh.HPageBreaks.Count + 1
**新增一個名稱範圍叫 "總頁數"，取R1C1格式，看有幾個HPageBreak 再+ 1 **
那AJ欄要怎麼連到"總頁數"呢?
**** 不是有請你 在AJ欄原本公式=IF(AT14="","",$AT$74) , 改公式 =總頁數****
作者: simplehope    時間: 2016-10-8 18:51     標題: 匯出資料到新工作表，如何解決有空白列，資料不連貫問題

本帖最後由 simplehope 於 2016-10-8 18:52 編輯

之前寫了個VBA，做匯出到新工作表可以成連貫資料，
原本A欄(No.的欄位)無公式，但因為要自動流水號需求，把A欄(No.的欄位)套公式做流水號之後，
如下圖示
[attach]25497[/attach]

再匯出後就有資料不連貫問題
如下圖示
[attach]25498[/attach]

小弟駑鈍實在試不出方法解決，只好又來請大大幫幫忙了~~謝謝
[attach]25496[/attach]
作者: simplehope    時間: 2016-10-8 20:12

回復 8# GBKEE


感謝G大，受教了~~可以用了!
作者: GBKEE    時間: 2016-10-9 08:14

回復 9# simplehope
試試看
  1. Option Explicit
  2. Sub 匯出地磅資料到新工作表()
  3.     Dim Sh(1 To 2), Rng(1 To 2) As Range, xCol As Integer, R As Integer
  4.     Application.ScreenUpdating = False
  5.     Set Sh(1) = Sheets("Mom (38P) (2)")    '**防止出錯: 指定工作表名稱***
  6.     'Set Sh(1) = ActiveSheet ''抓目前工作表名稱
  7.     '防呆1
  8.     For Each Sh(2) In Sheets
  9.         If InStr(Sh(2).Name, "匯出") Then
  10.             Application.DisplayAlerts = False
  11.             Sh(2).Delete
  12.             Application.DisplayAlerts = True
  13.             Exit For
  14.         End If
  15.     Next
  16.     With Sheets.Add(, Sheets(Sheets.Count))
  17.         .Name = Sh(1).Name & "匯出"
  18.         Set Sh(2) = ActiveSheet
  19.     End With
  20.     Sh(1).Select
  21.     Sh(1).Range("A1:AM15").Copy
  22.     MyCopy Sh(2).Range("A1")
  23.     With Sh(1)
  24.         xCol = .VPageBreaks(1).Location.Column - 1
  25.         For i = 0 To .HPageBreaks.Count
  26.             If i = 0 Then
  27.                 Set Rng(1) = .Range("A16")
  28.             Else
  29.                 Set Rng(1) = .HPageBreaks(i).Location.Range("A16")
  30.             End If
  31.             If Rng(1).Cells(1, 6) <> "" Then
  32.                 With Rng(1)
  33.                     R = .Cells(1, 6).End(xlDown).Row - .Row
  34.                     If R < 25 Then R = R + 1
  35.                     Rng(1).Resize(R, xCol).Copy
  36.                 End With
  37.                 With Sh(2).Range("A" & Rows.Count).End(xlUp)(2)      ' (2)= .Offset(1) = .Cells(2)
  38.                     If .Row < 16 Then        'A13:A15 為合併儲存格 : .Offset(1)-> = A14
  39.                         Set Rng(2) = .Parent.Range("A16")
  40.                     Else
  41.                         Set Rng(2) = .Cells
  42.                     End If
  43.                 End With
  44.                 MyCopy Rng(2)
  45.             Else
  46.                 Exit For
  47.             End If
  48.         Next
  49.     End With
  50.     Application.ScreenUpdating = True
  51.     MsgBox ("匯出完成")
  52. End Sub
  53. Sub MyCopy(Rng As Range)   '程式(傳遞參數)  : 相同的程式碼可用
  54.     With Rng
  55.         .PasteSpecial Paste:=xlPasteValues              '值
  56.         .PasteSpecial Paste:=xlPasteColumnWidths '欄寬
  57.         .PasteSpecial Paste:=xlPasteFormats            '格式
  58.     End With
  59. End Sub
複製代碼
作者: 准提部林    時間: 2016-10-9 10:34

  1. Sub 匯出地磅資料到新工作表()
  2. Dim vSht As Worksheet, R&, vR As Range, SHN$, xSht As Worksheet

  4. Set vSht = ActiveSheet: SHN = vSht.Name & "匯出"
  5. On Error Resume Next: Set xSht = Sheets(SHN): On Error GoTo 0
  6. If xSht Is Nothing Then Set xSht = Sheets.Add(after:=Sheets(Sheets.Count))

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

  19. On Error Resume Next
  20. With xSht.Range("AK16:AK" & R)
  21.      .SpecialCells(xlCellTypeConstants, 22).EntireRow.Delete '刪除〔文字〕格整列
  22.      .SpecialCells(xlCellTypeBlanks).EntireRow.Delete  '刪除〔空白格〕整列
  23. End With
  24. On Error GoTo 0

  26. xSht.Select
  27. End Sub
複製代碼
　
[attach]25499[/attach]
　
　
作者: simplehope    時間: 2016-10-9 17:05

回復 11# GBKEE

首先感謝G大花那麼多時間，還這麼快回應，超感動的！
執行後會有"變數未定義"錯誤，程式顯示在 For i = 0 To .HPageBreaks.Count ，當中的i 反白

小弟用自已原本的VBA碼，土炮解決問題如下：
因能力不足從輸出頁(來源頁)改複製範圍，就換從輸入頁(匯出頁) 下手
原本判斷[A16]向下到最後一列再offset一列, 改由從[F16]開始判斷，向下到最後一列再offset到A欄，
因F欄在輸出頁若空白，原本就無公式(無資料)，所以到了匯出頁也是無資料，用以上方法便可以有複製資料連續性

很佩服非使用者的G大，能寫出符合實際用途又如此簡約有效率的程式碼！
小弟功力尚淺寫出的程式很粗糙，對G大程式碼暫時只能望而興嘆，慢慢研究啊
  1. Sub 匯出地磅資料到新工作表()
  2.    
  3.     shn = ActiveSheet.Name
  4.         
  5.     '防呆1
  6.     For e = 2 To Sheets.Count
  7.         If shn & "匯出" = Sheets(e).Name Then
  8.             Application.DisplayAlerts = False
  9.             Sheets(shn & "匯出").Delete
  10.             Application.DisplayAlerts = True
  11.         Exit For
  12.     End If
  13.     Next

  15.    
  16.     Application.ScreenUpdating = False
  17.    


  20.     Worksheets.Add after:=Worksheets(Sheets.Count)
  21.     Worksheets(Sheets.Count).Name = shn & "匯出"

  23.     '抓取欄位 新增
  24.     Worksheets(shn).Select
  25.     Range("A1:AM15").Select
  26.     Range("A1:AM15").Copy
  27.     Worksheets(Sheets.Count).Select
  28.     Range("A1").Select
  29.     Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
  30.     SkipBlanks:=False, Transpose:=False
  31.     ActiveSheet.Paste

  33.     '抓取每頁資料內容(使用迴圈)
  34.     Worksheets(shn).Select
  35.     Dim i As Integer, j As Integer
  36.     j = Range("AT51").Value
  37.    
  38.     For i = 16 To 16 + j * 52 Step 52 '應要J-1, 但若只有一頁會有錯，多匯出一頁沒差
  39.         Worksheets(shn).Select
  40.         Range("a" & i & ":am" & i).Select
  41.         Range(Selection, Selection.End(xlToRight)).Select
  42.         Range(Selection, Selection.End(xlDown)).Select
  43.         Selection.Copy
  44.         Worksheets(Sheets.Count).Select

  46.     If Worksheets(Sheets.Count).Range("F16") = "" Then
  47.         Range("A16").Select
  48.         ActiveSheet.Paste '先貼一次含公式
  49.         Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, _
  50.         SkipBlanks:=False, Transpose:=False '再貼一次把公式拿掉
  51.         Range("F16").End(xlDown).Offset(1, -5).Clear '刪除A欄資料,以利貼上資料連續
  52.     Else
  53.         Worksheets(Sheets.Count).Range("F16").End(xlDown).Offset(1, -5).Select
  54.         ActiveSheet.Paste '先貼一次含公式
  55.         Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
  56.         xlNone, SkipBlanks:=False, Transpose:=False '再貼一次把日期變為文字
  57.       
  58.     End If
  59. Next

  61. end sub
複製代碼
作者: 准提部林    時間: 2016-10-9 17:39

沒注意原表公式參照格在複製範圍之外，修改一下：

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
作者: simplehope    時間: 2016-10-9 18:17

回復 12# 准提部林

感謝准大發功救世！
准大的概念是對輸出頁做修改，很驚訝程式碼竟能這樣寫！太厲害！就算我想破頭也想不出來…
程式碼完全沒問題，惟一的問題是小弟看不太懂以下：

.SpecialCells(xlCellTypeConstants, 22).EntireRow.Delete '刪除〔文字〕格整列
括號內為何要加 ,22這參數? F1查詢沒看到有說明22
[attach]25508[/attach]

程式碼最後加的On Error GoTo 0，用意為何？
F1查詢: 停止現在程序裏任何已啟動的錯誤處理程式。
會建議任何程式碼， 都在結尾加上"On Error GoTo 0" 嗎？
作者: simplehope    時間: 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
作者: simplehope    時間: 2016-10-9 18:46

回復 16# simplehope

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

回復 17# simplehope

疑問用小弟原本的程式碼會不會有這問題，
回頭看才發現，原來是我貼上兩次…第一次直接paste, 第二次貼上值&格式，所以才沒出現缺乏參照的問頭
…真是土炮+瞎貓碰上死秏子…
作者: 准提部林    時間: 2016-10-9 20:03

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

回復 15# simplehope


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

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

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

回復 16# simplehope


公式參照並未帶工作表名稱引數，
因此貼至其它表時，它參照的是本身表的儲存格，
但這表的參照格是空白的，公式值當然是錯誤的！
作者: 准提部林    時間: 2016-10-9 20:15

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

回復 18# simplehope


您第一次是公式原盤貼過來，再貼成值，這就是參照遺失問題，
將原表ＡＶ１改成〔卸櫃〕，再執行您原來程式，
手工去比對兩表Ｎ／Ｐ兩欄計算結果看看！！！
作者: Andy2483    時間: 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
作者: Andy2483    時間: 2022-12-12 16:44

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

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
作者: Andy2483    時間: 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



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