彰化一整天的論壇

 找回密碼
 立即註冊
查看: 1706|回復: 10

如何結合兩個功能VBA與快速刪除不須要的工作表

[複製鏈接]
發表於 2020-12-29 10:45:06 | 顯示全部樓層 |閱讀模式
呈上篇 請問如何設定VBA自動判斷 [複製工作表某區間的資料]目前想要將結合另外一個刪除若L7沒有資料的客戶工作表功能,如下VBA程式內容:

  1. Sub 刪除在範例活頁簿當中L7若沒有資料的工作表()
  2.     Dim mainworkBook As Workbook
  3.    
  4.     Set mainworkBook = ActiveWorkbook
  5.             
  6.     Dim skipSheet As Integer
  7.    
  8.     '跳過前2個Sheet用
  9.     skipSheet = 0
  10.    
  11.       
  12.     For Each Sheet In mainworkBook.Sheets
  13.    
  14.         Dim vlaue As String
  15.         
  16.         Value = Sheet.Range("L7")
  17.         
  18.         '跳過前2個sheet
  19.         If skipSheet > 1 Then
  20.         
  21.             If IsEmpty(Value) = True Then
  22.             
  23.               Application.DisplayAlerts = False
  24.               Sheet.Delete
  25.               Application.DisplayAlerts = True
  26.    
  27.             End If
  28.         End If
  29.         
  30.         skipSheet = skipSheet + 1
  31.     Next
  32. End Sub
複製代碼
請問要如何結合以呼叫Call funtion結合兩者VBA?
(附擋壓縮檔裡面的範例活頁簿中我已將兩者VBA放進去)

另,我實際上的客戶工作表有180~200個工作表在範例活頁簿中,
請問以上的刪除工作表的VBA可以如何做簡化或是加速在活頁簿當中刪除的處理效率?
因我實際操作下來,刪除L7的沒有訂單資料的客戶工作表,如此執行程式的時間需要10~15分鐘左右



範例.rar

82.83 KB, 下載次數: 1

售價: 2 金錢  [記錄]  [購買]

結合兩者VBA範例活頁簿

回復

使用道具 舉報

發表於 2020-12-29 11:57:27 | 顯示全部樓層
您可以把要刪除的工作表在到陣列,最後再一些刪除.語法如下.
  1. Sub 巨集1()
  2. '
  3. ' 巨集1 巨集
  4. '

  5. '
  6.     Sheets(Array("工作表2", "工作表3", "工作表4")).Select
  7.     ActiveWindow.SelectedSheets.Delete
  8. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-29 12:33:05 | 顯示全部樓層
imingho 發表於 2020-12-29 11:57
您可以把要刪除的工作表在到陣列,最後再一些刪除.語法如下.

imingho大大, 因為我的工作表很多, 除了您上面自己慢慢擅打工作表名稱的方式刪除,
反而用VBA判斷1百多個工作表的L7儲存格去刪除的方式, 會比較慢是嗎?

  1. Sheets(Array("工作表2", "工作表3", "工作表4")).Select
  2.     ActiveWindow.SelectedSheets.Delete
複製代碼
回復 支持 反對

使用道具 舉報

發表於 2020-12-29 14:02:48 | 顯示全部樓層
luckysan 發表於 2020-12-29 12:33
imingho大大, 因為我的工作表很多, 除了您上面自己慢慢擅打工作表名稱的方式刪除,
反而用VBA判斷1百多個 ...

您有使用過split函數嗎?
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-29 14:22:27 | 顯示全部樓層
imingho 發表於 2020-12-29 14:02
您有使用過split函數嗎?

Split沒試過...這個不會
回復 支持 反對

使用道具 舉報

發表於 2020-12-29 15:31:27 | 顯示全部樓層
luckysan 發表於 2020-12-29 14:22
Split沒試過...這個不會

我做了一個簡單的範例.您看懂就會修改了.
  1. Private Sub CommandButton1_Click()
  2.     Dim i As Integer
  3.    
  4.     For i = Sheets.Count To 10
  5.         Sheets.Add after:=Sheets(Sheets.Count)
  6.     Next
  7.    
  8.     MsgBox "產生完成"
  9.     Sheets(1).Activate
  10. End Sub

  11. Private Sub CommandButton2_Click()
  12.     Dim i As Integer
  13.    
  14.     Dim DelSheetName As String
  15.    
  16.     Dim DelSheetNames As Variant
  17.    
  18.     For i = 2 To Sheets.Count
  19.         If i Mod 2 = 0 Then
  20.            DelSheetName = DelSheetName & Sheets(i).Name & ","
  21.         End If
  22.     Next
  23.    
  24.     If Len(DelSheetName) > 0 Then '去除最後逗號
  25.         DelSheetName = Left(DelSheetName, Len(DelSheetName) - 1)
  26.         
  27.         DelSheetNames = Split(DelSheetName, ",")
  28.         
  29.         Sheets(DelSheetNames).Delete
  30.         
  31.         MsgBox "刪除完成"
  32.     End If
  33.    
  34.    
  35. End Sub
複製代碼

工作表新增與批次刪除.xlsm

25.67 KB, 下載次數: 1

售價: 1 金錢  [記錄]

回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-29 16:18:36 | 顯示全部樓層
imingho 發表於 2020-12-29 15:31
我做了一個簡單的範例.您看懂就會修改了.

但我的空白資料工作表示沒有規則(偶數或奇數工作表)排序,
我主要是標題以下的單身沒有key in任何資料,就要刪除該無資料內容的工作表
回復 支持 反對

使用道具 舉報

發表於 2020-12-29 16:36:14 | 顯示全部樓層
luckysan 發表於 2020-12-29 16:18
但我的空白資料工作表示沒有規則(偶數或奇數工作表)排序,
我主要是標題以下的單身沒有key in任何資料,就 ...

您的規則不是這幾行.
  1.             If IsEmpty(Value) = True Then
  2.             
  3.               Application.DisplayAlerts = False
  4.               Sheet.Delete
  5.               Application.DisplayAlerts = True
  6.    
  7.             End If
複製代碼
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-29 16:55:37 | 顯示全部樓層
imingho 發表於 2020-12-29 16:36
您的規則不是這幾行.

是下方這樣改嗎, 但無法刪除

  1. Sub 老師刪除範例()

  2. Dim i As Integer

  3. Dim mainworkBook As Workbook
  4.    
  5.     Set mainworkBook = ActiveWorkbook
  6.             
  7.         
  8.     '跳過前2個Sheet用
  9.     skipSheet = 0
  10.    
  11.       
  12.     For Each Sheet In mainworkBook.Sheets
  13.    
  14.         Dim vlaue As String
  15.         
  16.         Value = Sheet.Range("L7")
  17.         
  18.         '跳過前2個sheet
  19.         If skipSheet > 1 Then
  20.    
  21.         For i = 2 To Sheets.Count
  22.         If IsEmpty(Value) = True Then
  23.         
  24.         DelSheetName = Left(DelSheetName, Len(DelSheetName) - 1)
  25.         
  26.         DelSheetNames = Split(DelSheetName, ",")
  27.         
  28.         Sheets(DelSheetNames).Delete
  29.         
  30.         MsgBox "刪除完成"
  31.               
  32.        End If
  33.        Next
  34.    
  35.    
  36. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

發表於 2020-12-29 20:02:12 | 顯示全部樓層
luckysan 發表於 2020-12-29 16:55
是下方這樣改嗎, 但無法刪除
  1. Sub 老師刪除範例()

  2. Dim i As Integer

  3. Dim mainworkBook As Workbook
  4.    
  5.     Set mainworkBook = ActiveWorkbook
  6.             
  7.         
  8.     '跳過前2個Sheet用
  9.     skipSheet = 0
  10.    
  11.       
  12.     For Each Sheet In mainworkBook.Sheets
  13.    
  14.         Dim vlaue As String
  15.         
  16.         Value = Sheet.Range("L7")
  17.         
  18.         '跳過前2個sheet
  19.         If skipSheet > 1 Then

  20.             If IsEmpty(Value) = True Then
  21.             
  22.    
  23.                 DelSheetName = DelSheetName & Sheet.Name & ","
  24.             
  25.             End If
  26.         End If
  27.         
  28.         skipSheet = skipSheet + 1
  29.     Next
  30.       
  31.     If Len(DelSheetName) > 0 Then '去除最後逗號
  32.         DelSheetName = Left(DelSheetName, Len(DelSheetName) - 1)
  33.         
  34.         DelSheetNames = Split(DelSheetName, ",")
  35.         
  36.         Sheets(DelSheetNames).Delete
  37.         
  38.         MsgBox "刪除完成"
  39.     End If

  40.    
  41. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)

GMT+8, 2021-9-21 15:37 , Processed in 0.119292 second(s), 20 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回復 返回頂部 返回列表