ML089

回復 9# jsc0518


A欄空白時若H欄有資料 不刪除嗎?

Sub ex()
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        For Each x In Array("", "TPD", "TPD-both", "TPD-viewing", "GSA")
            If Cells(i, 1) = "" And Cells(i, "H") <> "" Then Exit For
            If Cells(i, 1) = x Then Cells(i, 1).EntireRow.Delete
        Next
    Next
End Sub

jsc0518

回復 6# 准提部林


Dear ikboy / 准提部林 / ML089

我在H欄有設定資料，但A欄是空白的，若H欄資料是位於最下方時，程式無法刪除該列

下載 (52.58 KB)

2017-2-8 15:58

下載 (28.88 KB)

2017-2-8 15:58

028-01.zip (10.39 KB)

下載次數: 4

2017-2-8 15:59

jsc0518

回復 11# ML089


A欄空白時若H欄有資料 不刪除嗎?   --> A欄空白，一律要刪除

准提部林

Sub zz2()
Dim T$, xR As Range, xE As Range, R&
T = "_TPD_TPD-both_TPD-viewing_GSA_"
R = Range([A1], ActiveSheet.UsedRange).Rows.Count
Set xE = Range("A" & R + 1)
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

ikboy

其實准提部林大的已解決了, 這衹是另一方法:

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 = IIf([a65536].End(3).Row > [h65536].End(3).Row, [a65536].End(3).Row, [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.     End If
    
16. Next
    
17. rng.EntireRow.Delete
    
18. Application.ScreenUpdating = 1
    
19. End Sub

複製代碼

jsc0518

回復 14# 准提部林


Dear 准提部林
測試成功
請問哪一個語法是刪除A欄空白列阿?

准提部林

回復 16# jsc0518


If xR = "" Or InStr(T, "_" & xR & "_") Then Set xE = Union(xE, xR)
就已包含"空白"及"關鍵字",
真正問題是, H欄最後一格與A欄不一致(較多),
所以只用A欄去檢測最後一格, 就漏了H欄,
用UsedRange可以包含所有已使用區塊,
但若前幾列是完全空白, 將漏抓這前幾列,
故, 用 Range([A1], UsedRange) 來函蓋整個區塊!

Kubi

不用範圍物件變數，應可加快執行速度。

Sub test()
    Dim d As Object
    Dim arr
    st = Timer
    Set d = CreateObject("Scripting.Dictionary")
    For Each x In Split("TPD.TPD-both.TPD-viewing.GSA", ".")
        d(x) = ""
    Next x
    arr = Range("A1:A" & ActiveSheet.UsedRange.Rows.Count)
    For i = 1 To UBound(arr)
        If d.exists(arr(i, 1)) Then arr(i, 1) = ""
    Next i
    [A1].Resize(UBound(arr), 1) = arr
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Set d = Nothing
    arr = ""
    MsgBox Format(Timer - st, "0.0秒")
End Sub

ML089

回復 13# jsc0518

最後一列 Range([A1], ActiveSheet.UsedRange).Rows.Count 參考14樓

Sub ex()
    For i = Range([A1], ActiveSheet.UsedRange).Rows.Count To 1 Step -1
        For Each x In Array("", "TPD", "TPD-both", "TPD-viewing", "GSA")
            If Cells(i, 1) = x Then Cells(i, 1).EntireRow.Delete
        Next
    Next
End Sub

jsc0518

回復 17# 准提部林


   了解，感謝您的回覆!