[發問] 依條件刪除整列資料

PJChen

早安：

請問以下該如何寫程式??
a) 執行程式時,不要變動CVS工作表A:S的公式及格式
b) CVS工作表A欄 & I欄符合條件則整列刪除,並另存新檔....AAA_YYYYmmdd

c) A欄:以VBA工作表[AS7]為條件,當[AS7]="",則A欄不比對,當[AS7]="V",則符合條件,將A欄="結束",整列刪除

d) I欄條件:以VBA工作表[AS6]為條件,當[AS6]="",則I欄不比對,當I欄的日期="" or I欄日期<[AS6],整列刪除

促銷資訊.rar (47.56 KB)

下載次數: 7

2021-3-2 05:19

jcchiang

回復 1# PJChen

試試看
Sub ex()
Dim fds As Object, fs$, Path$
Dim c As Variant, a As Variant
Application.ScreenUpdating = False
Set c = Nothing
Path = ThisWorkbook.Path
For Each a In Sheets("CVS").Range([a3], [a3].End(4))
   If Sheets("VBA").[AS7] = "V" And Sheets("VBA").[AS6] <> "" Then '[AS7] & [AS6]皆不為空白
      If a = "結束" Or a.Offset(, 8) = "" Or a.Offset(, 8) < Sheets("VBA").[AS6] Then '比對A欄是否為"結束",I欄是否為空白或小於[AS6]
         If c Is Nothing Then
           Set c = a.Resize(, 14)
         Else
           Set c = Union(c, a.Resize(, 14))
         End If
      End If
   ElseIf Sheets("VBA").[AS7] = "V" And Sheets("VBA").[AS6] = "" Then '[AS7]不為空白,[AS6]為空白
      If a = "結束" Then                                              '比對A欄是否為"結束"
         If c Is Nothing Then
           Set c = a.Resize(, 14)
         Else
           Set c = Union(c, a.Resize(, 14))
         End If
      End If
   ElseIf Sheets("VBA").[AS7] = "" And Sheets("VBA").[AS6] <> "" Then '[AS7]為空白,[AS6]不為空白
      If a.Offset(, 8) = "" Or a.Offset(, 8) < Sheets("VBA").[AS6] Then '比對I欄是否為空白或小於[AS6]
         If c Is Nothing Then
           Set c = a.Resize(, 14)
         Else
           Set c = Union(c, a.Resize(, 14))
         End If
      End If
   End If
Next
c.EntireRow.Delete  '將符合條件的列刪除
Application.DisplayAlerts = False
Set fds = CreateObject("Scripting.filesystemobject")
fs = Dir(Path & "\AAA-" & Format(Date, "yyyymmdd") & "*.xlsx")  '來源檔案資料夾內的檔案名
Do Until fs = "" '直到讀取檔案名是空字串
   If fds.FileExists(Path & fs) Then Kill Path & fs '如果檔案已經存在就先刪除檔案
   fs = Dir '下一個檔案
Loop
ActiveWorkbook.SaveAs Filename:=Path & "\AAA-" & Format(Date, "yyyymmdd") + ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Workbooks("促銷資訊.xlsm").Close False
End Sub

PJChen

回復 2# jcchiang

感謝大大的幫忙,
程式OK

准提部林

只做刪除部份
Sub TEST()
Dim Arr, KS$, DS, D, R&, xR As Range, xU As Range, N&
If [VBA!AS7] = "V" Then KS = "結束" Else KS = "|^|"
If IsDate([VBA!AS6]) Then DS = CDate([VBA!AS6]) Else DS = -9
R = [CVS!A65536].End(xlUp).Row - 2
If R <= 0 Then Exit Sub
For Each xR In [CVS!A3].Resize(R)
    If IsDate(xR(1, 9)) Then D = CDate(xR(1, 9)) Else D = 0
    If xR = KS Or xR(1, 9) < DS Then
       N = N + 1
       If N = 1 Then Set xU = xR Else Set xU = Union(xU, xR)
    End If
Next
If N > 0 Then xU.EntireRow.Delete
MsgBox "共有 " & N & " 筆被刪除 "
End Sub


'=========================

PJChen

回復 4# 准提部林

准大好,
原程式執行沒問題,稍加修改為可以自行開啟,並將工作表指定為Sh,但無法執行,告知需要物件?
Set Sh = xB.Sheets("CVS")
R = [Sh!A65536].End(xlUp).Row - 2

另資料大幅刪除後,我想讓資料畫面停在工作表有資料的最後一列,但無作用,請問要怎麼改寫?
xrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & xrow).Activate

整列刪除_促銷資訊.rar (44.95 KB)

下載次數: 3

2021-3-4 23:53

准提部林

回復 5# PJChen

R = Sh.[A65536].End(xlUp).Row - 2

For Each xR In Sh.[A3].Resize(R)

Sh.Cells(Rows.Count, 1).End(xlUp).Select '最後一行

准提部林

回復 5# PJChen


Do While FN <> ""
Set xB = Nothing
On Error Resume Next: Set xB = Workbooks(FN): On Error GoTo 0 '這用來檢查檔案是否已開啟
If xB Is Nothing Then Set xB = Workbooks.Open(PH & FN) '檔案未開啟時才能用open, 否則重覆開啟會造成當機
Set Sh = xB.Sheets("CVS")

注意紅色部份