123
返回列表 上一主題 發帖

可否簡化 VBA 語法

jsc0518

帖子
455 
主題
111 
精華
0 
積分
563 
點名
254  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2013-11-7 
最後登錄
2024-12-21 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2017-2-7 14:16 | 只看該作者

可否簡化 VBA 語法

大家好，我寫一串語法
但自覺得過程太冗長，是否可以簡化程式語法


條件1.在A欄位，只要出現是"空白"，就整列移除
條件2.在A欄位，只要出現這些英文，就整列移除 : TPD . TPD-both . TPD-viewing . GSA

Sub Step1()

On Error Resume Next
[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub

Sub Step2()

Dim yy
yy = "TPD"
For I = [a65536].End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Rows(I), yy) > 0 Then Rows(I).Delete
Next I
End Sub

Sub Step3()

Dim yy
yy = "TPD-both"
For I = [a65536].End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Rows(I), yy) > 0 Then Rows(I).Delete
Next I
End Sub

Sub Step4()

Dim yy
yy = "TPD-viewing"
For I = [a65536].End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Rows(I), yy) > 0 Then Rows(I).Delete
Next I
End Sub

Sub Step5()

Dim yy
yy = "GSA"
For I = [a65536].End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Rows(I), yy) > 0 Then Rows(I).Delete
Next I
End Sub

在麻煩各位先進!
收藏 分享
Just do it.

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
17  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-11-19 

2016猴年全勤獎章
2#
發表於 2017-2-8 09:37 | 只看該作者
回復 1# jsc0518


Try this:
  1. Sub zz()
  2. Application.ScreenUpdating = 0
  3. Dim x(), rng As Range, ar, Myr&
  4. x = Array("TPD", "TPD-both", "TPD-viewing", "GSA")
  5. Myr = [a65536].End(3).Row
  6. ar = Range("a1:a" & Myr)
  7. Set rng = Cells(Myr + 1, 1)
  8. For i = 1 To UBound(ar)
  9.     If Len(ar(i, 1)) = 0 Then
  10.         Set rng = Union(rng, Cells(i, 1))
  11.     Else
  12.         For j = 0 To UBound(x)
  13.             If InStr(ar(i, 1), x(j)) Then Set rng = Union(rng, Cells(i, 1))
  14.         Next
  15.     Next
  16. Next
  17. rng.EntireRow.Delete
  18. Application.ScreenUpdating = 1
  19. End Sub
複製代碼
hth
ikboy

TOP

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
3#
發表於 2017-2-8 09:58 | 只看該作者
  1. Sub ex()
  2.     For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
  3.         For Each x In Array("", "TPD", "TPD-both", "TPD-viewing", "GSA")
  4.             If Cells(i, 1) = x Then Cells(i, 1).EntireRow.Delete
  5.         Next
  6.     Next
  7. End Sub
複製代碼
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

jsc0518

帖子
455 
主題
111 
精華
0 
積分
563 
點名
254  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2013-11-7 
最後登錄
2024-12-21 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章論壇贊助勳章
4#
發表於 2017-2-8 10:00 | 只看該作者
回復 2# ikboy

您好，感謝回覆，但在執行過程中會發生錯誤訊息，如下圖




028-01.zip (11.74 KB)

在麻煩您了!
Just do it.

TOP

jsc0518

帖子
455 
主題
111 
精華
0 
積分
563 
點名
254  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2013-11-7 
最後登錄
2024-12-21 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章論壇贊助勳章
5#
發表於 2017-2-8 10:07 | 只看該作者
回復 3# ML089

ML089
感謝您的提供，測試成功，謝謝您!
Just do it.

TOP

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-12-20 
6#
發表於 2017-2-8 10:17 | 只看該作者
本帖最後由 准提部林 於 2017-2-8 10:19 編輯

若只檢查Ａ欄的內容，參考如下：
Sub zz2()
Dim T$, xR As Range, xE As Range
T = "_TPD_TPD-both_TPD-viewing_GSA_"　'將索引值用"_"連接
Set xE = [A65536].End(xlUp)(2)　'設Ａ欄最後一格的下一格為 xE
For Each xR In Range([A1], xE(0))
　　If xR = "" Or InStr(T, "_" & xR & "_") Then Set xE = Union(xE, xR)
Next
xE.EntireRow.Delete
End Sub

資料多的話，檢查完畢再一次刪，速度較快∼∼

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
17  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-11-19 

2016猴年全勤獎章
7#
發表於 2017-2-8 11:56 | 只看該作者
回復 4# jsc0518


Sorry 沒測試, 己更正:
Sub zz()
Application.ScreenUpdating = 0
Dim x(), rng As Range, ar, Myr&
x = Array("TPD", "TPD-both", "TPD-viewing", "GSA")
Myr = [a65536].End(3).Row
ar = Range("a1:a" & Myr)
Set rng = Cells(Myr + 1, 1)
For i = 1 To UBound(ar)
    If Len(ar(i, 1)) = 0 Then
        Set rng = Union(rng, Cells(i, 1))
    Else
        For j = 0 To UBound(x)
            If InStr(ar(i, 1), x(j)) Then Set rng = Union(rng, Cells(i, 1))
        Next
    End if
Next
rng.EntireRow.Delete
Application.ScreenUpdating = 1
End Sub

TOP

jsc0518

帖子
455 
主題
111 
精華
0 
積分
563 
點名
254  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2013-11-7 
最後登錄
2024-12-21 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章論壇贊助勳章
8#
發表於 2017-2-8 12:22 | 只看該作者
回復 7# ikboy


您好，我有測試過，但仍有一些問題，若A欄是空白的(我要刪除列)，但在H欄有資料(我不需要)
經測試後，它(H爛)的資料仍會存在，並不會因為A欄是空白而刪除整列
Just do it.

TOP

jsc0518

帖子
455 
主題
111 
精華
0 
積分
563 
點名
254  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2013-11-7 
最後登錄
2024-12-21 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章論壇贊助勳章
9#
發表於 2017-2-8 12:23 | 只看該作者
回復 3# ML089

您好，我有測試過，但仍有一些問題，若A欄是空白的(我要刪除列)，但在H欄有資料(我不需要)
經測試後，它(H爛)的資料仍會存在，並不會因為A欄是空白而刪除整列
Just do it.

TOP

jsc0518

帖子
455 
主題
111 
精華
0 
積分
563 
點名
254  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2013-11-7 
最後登錄
2024-12-21 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章論壇贊助勳章
10#
發表於 2017-2-8 12:24 | 只看該作者
回復 6# 准提部林

您好，我有測試過，但仍有一些問題，若A欄是空白的(我要刪除列)，但在H欄有資料(我不需要)
經測試後，它(H爛)的資料仍會存在，並不會因為A欄是空白而刪除整列
Just do it.

TOP

        靜思自在 : 愛不是要求對方，而是要由自身的付出。
123
返回列表 上一主題