返回列表 上一主題 發帖

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

回復 12# 准提部林

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

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


程式碼最後加的On Error GoTo 0,用意為何?
F1查詢: 停止現在程序�堨籉韝w啟動的錯誤處理程式。
會建議任何程式碼, 都在結尾加上"On Error GoTo 0" 嗎?

TOP

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

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

[版主管理留言]
  • 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

  14.    
  15.     Application.ScreenUpdating = False
  16.    


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

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

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

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

  54. end sub
複製代碼

TOP

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

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

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

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

  22. xSht.Select
  23. End Sub
複製代碼
 
Xl0000046.rar (144.56 KB)
 
 

TOP

回復 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

回復 8# GBKEE


感謝G大,受教了~~可以用了!

TOP

匯出資料到新工作表,如何解決有空白列,資料不連貫問題

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

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


再匯出後就有資料不連貫問題
如下圖示


小弟駑鈍實在試不出方法解決,只好又來請大大幫幫忙了~~謝謝
WB2.zip (790.07 KB)

TOP

本帖最後由 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) , 改公式 =總頁數****
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 5# GBKEE

G大不好意思,執行到一半會出現錯誤:"陣列索引超出範圍"如下圖:
   

猜問題出在 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欄要怎麼連到"總頁數"呢?
腦袋有點轉不過來

TOP

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


跟with •••end with
跟for each...in
跟if not 條件式 真的是很不熟啊…

TOP

        靜思自在 : 謊言像一朵盛開的鮮花,外表美麗,生命短暫。
返回列表 上一主題