123
返回列表 上一主題 發帖

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

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
11# 跳轉到 »
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
12#
發表於 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
複製代碼
　
Xl0000046.rar (144.56 KB)
　
　

TOP

simplehope

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

論壇贊助勳章
13#
發表於 2016-10-9 17:05 | 只看該作者
[版主管理留言]
  • GBKEE(2016/10/9 19:54): Dim Sh(1 To 2), Rng(1 To 2) As Range, xCol As Integer, R As Integer, i As Integer

回復 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
複製代碼

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
14#
發表於 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

TOP

simplehope

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

論壇贊助勳章
15#
發表於 2016-10-9 18:17 | 只看該作者
回復 12# 准提部林

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

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


程式碼最後加的On Error GoTo 0，用意為何？
F1查詢: 停止現在程序裏任何已啟動的錯誤處理程式。
會建議任何程式碼， 都在結尾加上"On Error GoTo 0" 嗎？

TOP

simplehope

帖子
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

simplehope

帖子
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

帖子
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

准提部林

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

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
20#
發表於 2016-10-9 20:10 | 只看該作者
回復 16# simplehope


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

TOP

        靜思自在 : 靜坐常恩己過、閒談莫論人非。
123
返回列表 上一主題