- 帖子
- 234
- 主題
- 19
- 精華
- 0
- 積分
- 276
- 點名
- 0
- 作業系統
- Windows XP
- 軟體版本
- office 2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2013-1-7
- 最後登錄
- 2021-10-7
|
2#
發表於 2021-3-3 10:08
| 只看該作者
回復 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 |
|
發表於 2021-3-4 10:32
| 
