iT邦幫忙

0

Excel VBA 如何自動保留最新並刪除舊的檔案

vb
  • 分享至 

  • xImage

各位先進
我的資料匣內有著如下,以不同時間存取為名的兩個類型的excel檔案
20210812_1300_data1.xls
20210812_1300_data2.xls
20210812_1330_data1.xls
20210812_1330_data2.xls
20210812_1400_data1.xls
20210812_1400_data2.xls
20210812_1430_data1.xls
20210812_1430_data2.xls
想請教一下,如何使用VB寫出僅抓取(保留)最新的檔案並自動刪除較舊的檔案?

08/13
很抱歉..新手訓練期間無法回應

japhenchen
我不會使用Powershell,但還是非常感謝您的幫忙

海綿寶寶
我試過了..沒問題..非常感謝您

圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

2 個回答

0
海綿寶寶
iT邦大神 1 級 ‧ 2021-08-12 15:51:05
最佳解答

1.複製貼上程式碼(在最底下)
2.修改 xls 檔所在路徑(sPath = "D:\kill")
3.先確定執行結果正確(如下範例)

D:\kill\20210812_1300_data1.xls       was deleted
D:\kill\20210812_1300_data2.xls       was deleted
D:\kill\20210812_1330_data1.xls       was deleted
D:\kill\20210812_1330_data2.xls       was deleted
D:\kill\20210812_1400_data1.xls       was deleted
D:\kill\20210812_1400_data2.xls       was deleted
D:\kill\20210812_1430_data1.xls       was saved
D:\kill\20210812_1430_data2.xls       was saved

4.再修改程式裡一列(會真的刪除)
'Kill dirPath & thisFile.Name
改成
Kill dirPath & thisFile.Name

改寫網路上抄來的程式碼如下

Option Explicit
Sub Main()
    Dim fileToBeSaved(1 To 2) As String
    Dim sPath As String
    Dim arr() As String
    
    sPath = "D:\kill\"
    
    arr = SortedFiles(sPath, "_data1.xls")
    fileToBeSaved(1) = arr(UBound(arr))
    
    arr = SortedFiles(sPath, "_data2.xls")
    fileToBeSaved(2) = arr(UBound(arr))
    
    Call deleteDataFiles(sPath, ".xls", fileToBeSaved)
End Sub
Sub deleteDataFiles(ByVal dirPath As String, ByVal fileType As String, ByVal arrSaved)
    Dim bSaved As Boolean
    Dim saveFile As Variant
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim listFolder As Object
    Set listFolder = fso.GetFolder(dirPath)
   
    Dim thisFile As Object
    For Each thisFile In listFolder.Files
        If Right(thisFile.Name, Len(fileType)) = fileType Then
            bSaved = False
            For Each saveFile In arrSaved
                If saveFile = thisFile.Name Then
                    bSaved = True
                End If
            Next
            If (bSaved = False) Then
                Debug.Print dirPath & thisFile.Name, " was deleted"
                'Kill dirPath & thisFile.Name
            Else
                Debug.Print dirPath & thisFile.Name, " was saved"
            End If
        End If
    Next thisFile
End Sub
Public Function SortedFiles(ByVal dirPath As String, ByVal fileType As String) As String()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim listFolder As Object
    Set listFolder = fso.GetFolder(dirPath)

    ' Make the list of names.
    Dim fileCount As Long
    fileCount = listFolder.Files.Count
    
    Dim fileNames() As String
    ReDim fileNames(1 To fileCount)
    
    Dim i As Long
    i = 1
    
    Dim thisFile As Object
    For Each thisFile In listFolder.Files
        If Right(thisFile.Name, Len(fileType)) = fileType Then
            fileNames(i) = thisFile.Name
            i = i + 1
        End If
    Next thisFile

    ' Return the sorted list.
    SortedFiles = QuickSort(fileNames, 1, fileCount)
End Function
' Use Quicksort to sort a list of strings.
'
' This code is from the book "Ready-to-Run
' Visual Basic Algorithms" by Rod Stephens.
' http://www.vb-helper.com/vba.htm
Public Function QuickSort(ByVal list As Variant, ByVal min As Long, ByVal max As Long) As String()
                      
    Dim midValue As String
    Dim high As Long
    Dim low As Long
    Dim i As Long
    Dim newList() As String
    newList = list
    
    ' If there is 0 or 1 item in the list,
    ' this sublist is sorted.
    If Not min >= max Then

        ' Pick a dividing value.
        i = Int((max - min + 1) * Rnd + min)
        midValue = newList(i)

        ' Swap the dividing value to the front.
        newList(i) = newList(min)

        low = min
        high = max
        Do
            ' Look down from hi for a value < mid_value.
            Do While newList(high) >= midValue
                high = high - 1
                If high <= low Then Exit Do
            Loop
        
            If high <= low Then
                newList(low) = midValue
                Exit Do
            End If

            ' Swap the lo and hi values.
            newList(low) = newList(high)

            ' Look up from lo for a value >= mid_value.
            low = low + 1
            Do While newList(low) < midValue
                low = low + 1
                If low >= high Then Exit Do
            Loop
        
            If low >= high Then
                low = high
                newList(high) = midValue
                Exit Do
            End If

            ' Swap the lo and hi values.
            newList(high) = newList(low)
        Loop

        ' Sort the two sublists.
        newList = QuickSort(newList, min, low - 1)
        newList = QuickSort(newList, low + 1, max)
    End If
    
    QuickSort = newList
End Function
0
japhenchen
iT邦超人 1 級 ‧ 2021-08-12 14:50:01

VBA找檔案的方法我不會,但Powershell我會
我剛學到一招除了最新的檔案,其他都殺掉的方法

把以下內容以文字編輯器,存成一個副檔名為 ps1 (不是PS5哦,是ps"one")的"超級批次檔",在上面按右鍵→以Powershell執行即可
路徑名是我的電腦下載資料夾,你自己再視情況修改

<# 下面那行的意思是 抓.../downloads/裡所有的 xls* 檔 | 按日期從舊到新排序 | 取得檔案物件 #>
<# | ← 這是管線,不懂的話要從頭開始學起,簡單說,就是把管線左邊的結果,直接傳給管線右邊的指令 #>
$files = @(Get-ChildItem -Path "C:\Users\JaphenChen\Downloads" -filter  "*.xls*" -File -Force -ErrorAction SilentlyContinue | sort-object LastWriteTimeUtc| Select-Object FullName | Foreach-Object { $_.FullName })
<# 下面那行[0..-2]指的就是從最舊一路排到倒數第二新的檔案,最新的那個檔案不跑 #>
foreach ($f in $files[0..-2]) { 
    <# 把檔案物件的完全檔名抓出來 #>
    $fp = [System.IO.Path]::GetFullPath($f)   
    <# 再確認..如果檔案確實存在的話 #>
    if ([System.IO.File]::Exists($fp)) {
        <# 刪除 ! #>
        Remove-Item $fp
    }
}    

powershell的ps1檔,你就當成超級版的批次檔看待就對了!

....

我要發表回答

立即登入回答