Макрос для архивирования определенных файлов с VBA - PullRequest
Новая
       11

Макрос для архивирования определенных файлов с VBA

0 голосов
/ 13 июня 2018

Каждую неделю я должен запускать этот отчет о количестве циклов.Когда отчет закончен, я должен вручную взять около 30 файлов, сгруппировать их по местоположению и заархивировать файлы.Я новичок в VBA и пытаюсь создать макрос, который будет автоматически группировать определенный набор файлов и объединять их вместе.Также мне нужно иметь возможность добавлять или удалять любые файлы, которые сгруппированы вместе.Ниже приведен список файлов и способы их группировки, и где я пытаюсь их сохранить.Ниже приведен код, который у меня есть для этого.Я знаю, что чего-то не хватает.

Вот два файла, о которых я говорю.Если кто-то может показать мне, что добавить в макрос, чтобы это работало, и сгруппировал другие файлы в другие папки zip, это было бы здорово.

Zip-папка с именем CYC 06-06-11-18 включает эти файлы.C06-06-11-18, C6K-06-11-18, C6M-06-11-18, C6V-06-11-18, CQU-06-11-18, CSU-06-11-18, T06-06-11-18,T6C-06-11-18, TSU-06-11-18.

Папка Zip с именем CYC D1-06-11-18 включает эти файлы.CD1-06-11-18, CS1-06-11-18, TD1-06-11-18, TS1-06-11-18.

Все файлы находятся в одной папке, и папка zip может находиться либо в той же папке, либо в новой.Пока почтовый файл может называться «CYC 06» или «CYC 11», или «CYC T1».Мне не нужно указывать дату в папке zip.

Эти файлы и папки zip сохраняются в пути к файлу ниже.Это то, что я хотел бы использовать, если это возможно. 

S:\ACCT\Inventory Control & Product Costing\Inventory Control - Reporting\RM Cycle Count - Data Collection\Zip Files

Вот макрос, с которым я работал.

Dim x As Integer
Dim fs o As Object
Dim result As Boolean

Sub Folder Info()
Application. Screen  Updating   = False
'------------------------------------
'DECLARE AND SET VARIABLES
    Dim s t r Path As String
    s t r  Path = 
    x = 0
    Set fs o = Create Object    ("Scripting. File System Object")
'------------------------------------
'CHECK FOLDERS AND SUBFOLDERS
    result = Extract File Info    (s t r Path)
'------------------------------------
'CLEANUP
    Set fs o = Nothing
    Msg Box x & " files have been zipped."
Application. Screen Updating = True
End Sub


Private Function Extract File Info(fs pec)
    On Error Go To Err Handler
'------------------------------------
'DECLARE AND SET VARIABLES
    Dim f l d r As Object, fi As Object, s f l d r As Object, o App As Object
    Dim Filename, f name As String
    Set f l d r = fs o. Get Folder(fs pec)
'------------------------------------
'CHECK FILES IN TOP FOLDER
    If f l d r. Files. Count <> 0 Then
        For Each fi In f l d r. Files
            s = Split(fi, ".")
            If In  St r (1, fi, "(C06)" “(CK6)” “(CB6)” “(C6M)” “(C6V)” “(CQU)” “(CSU)” “(T06)” “(T6C)” “(TQU)” “(TSU)”, 1) > 0 And U Case(Left(s(1), 2)) = "XL" Then
                s = Split(fi, ".")
                Filename = s(0) & ".zip"
                New Zip (CYC 06)
                f name = fi
                Set o App = Create Object("Shell. Application")
                o App. Name space(Filename).Copy Here s(0) & "." & s(1) 'F Name (I C t r)
                x = x + 1
            End If
access not allowed:
        Next
    End If
'------------------------------------
'CHECK SUBFOLDERS
    If f l d r. Sub Folders. Count > 0 Then
        For Each s f l d r In f l d r. Sub Folders
            Extract File Info (s f l d  r) 'RECURSIVE CHECK
        Next
    End If
'------------------------------------
'CLEANUP
permission denied:
    Extract File Info = True
    Set f l d r = Nothing
Exit Handler:
    Application. Screen Updating = True
    Exit Function
'------------------------------------
'HANDLE RETURNED ERROR
Err Handler:
    If Err.Number = 70 Then 'permission denied
        Err. Clear
        Msg Box f spec & Ch r (13) & "Permission Denied"
        Resume permission  denied
    Else
        Msg Box Err. Number & ": " & Err. Description
        Resume Exit Handler
    End If
End Function
...