VBA Giải nén nhiều Folder và xóa những File trong Folder sau khi đã giải nén

Liên hệ QC
vanaccex

vanaccex

Thành viên tiêu biểu
Tham gia
8/7/18
Bài viết
454
Được thích
305
Giới tính
Nữ
Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
vanaccex đã viết:
Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
Nhấp chuột vào đây để mở rộng...
thế tốt nhất là code tạo folder tên giống folder nén rồi xoá cái folder nén đi là xong.
 
Upvote 0
Bạn tải ứng dụng Win 7z ( bất kì file nào giải nén được ) về, sửa đường dẫn trong VBA tương ứng với đường dẫn ứng dụng

Public Const PathZipProgram = "D:\Program Files\7-Zip\"

Sửa đường dẫn thư mục cần giải nén:

Const fPathFile = "D:\Folder\"

*Copy thêm một Folder khác để tránh trường hợp mất File.

Code VBA:

PHP: 
'Tools -> References -> chọn Microsoft Scrtipting Runtime
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Public FileItem As Scripting.File
Public IsFileTypeExists As Boolean
Public oApp
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessID As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If

'--------------------------------------------------------------------------------------
Public Const PathZipProgram = "D:\Program Files\7-Zip\"
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103


Public Sub RunUnZip()
  Const fPathFile = "D:\Folder\"
  Set FSO = New Scripting.FileSystemObject
  If FSO.FolderExists(fPathFile) = False Then Exit Sub
  ListFilesInFolder FSO.GetFolder(fPathFile), True, True
  Set FileItem = Nothing
  Set SourceFolder = Nothing
  Set FSO = Nothing
End Sub
Public Sub ListFilesInFolder( _
              SourceFolder As Scripting.Folder, _
              IncludeSubfolders As Boolean, _
              Optional ByVal HasDel As Boolean)
  On Error Resume Next
  Dim FileFolder$, fileNameInZip
  For Each FileItem In SourceFolder.Files
    If LCase$(FileItem.Type) Like "*zip*" Then
      FileFolder = Replace$(FileItem.Path, FileItem.Name, "")
      ShellAndWait PathZipProgram & "7z.exe x -aoa" _
      & " " & Chr(34) & FileItem.Path & Chr(34) _
      & " -o" & Chr(34) & FileFolder & Chr(34) & " " & "*.*", vbHide
      If HasDel Then FSO.DeleteFile FileItem.Path
    End If
  Next FileItem
  If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
      ListFilesInFolder SubFolder, True, HasDel
    Next SubFolder
  End If
End Sub
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
  Dim hProg As Long
  Dim hProcess As Long, ExitCode As Long
  If IsMissing(WindowState) Then WindowState = 1
  hProg = Shell(PathName, WindowState)
  hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
  Do
    GetExitCodeProcess hProcess, ExitCode
    DoEvents
  Loop While ExitCode = STILL_ACTIVE
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
HeSanbi đã viết:
Bạn tải ứng dụng Win 7z ( bất kì file nào giải nén được ) về, sửa đường dẫn trong VBA tương ứng với đường dẫn ứng dụng

Public Const PathZipProgram = "D:\Program Files\7-Zip\"

Sửa đường dẫn thư mục cần giải nén:

Const fPathFile = "D:\Folder\"

*Copy thêm một Folder khác để tránh trường hợp mất File.

Code VBA:

PHP: 
'Tools -> References -> chọn Microsoft Scrtipting Runtime
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Public FileItem As Scripting.File
Public IsFileTypeExists As Boolean
Public oApp
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessID As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If

'--------------------------------------------------------------------------------------
Public Const PathZipProgram = "D:\Program Files\7-Zip\"
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103


Public Sub RunUnZip()
  Const fPathFile = "D:\Folder\"
  Set FSO = New Scripting.FileSystemObject
  If FSO.FolderExists(fPathFile) = False Then Exit Sub
  Set SourceFolder = FSO.GetFolder(fPathFile)
       
  ListFilesInFolder SourceFolder, True, True
End Sub
Public Sub ListFilesInFolder( _
              SourceFolder As Scripting.Folder, _
              IncludeSubfolders As Boolean, _
              Optional ByVal HasDel As Boolean)
  On Error Resume Next
  Dim FileFolder$, fileNameInZip
  For Each FileItem In SourceFolder.Files
    If LCase$(FileItem.Type) Like "*zip*" Then
      FileFolder = Replace$(FileItem.Path, FileItem.Name, "")
      ShellAndWait PathZipProgram & "7z.exe x -aoa" _
      & " " & Chr(34) & FileItem.Path & Chr(34) _
      & " -o" & Chr(34) & FileFolder & Chr(34) & " " & "*.*", vbHide
      If HasDel Then FSO.DeleteFile FileItem.Path
    End If
  Next FileItem
  If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
      ListFilesInFolder SubFolder, True
    Next SubFolder
  End If
  Set FileItem = Nothing
  Set SourceFolder = Nothing
  Set FSO = Nothing
End Sub
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
  Dim hProg As Long
  Dim hProcess As Long, ExitCode As Long
  If IsMissing(WindowState) Then WindowState = 1
  hProg = Shell(PathName, WindowState)
  hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
  Do
    GetExitCodeProcess hProcess, ExitCode
    DoEvents
  Loop While ExitCode = STILL_ACTIVE
End Sub
Nhấp chuột vào đây để mở rộng...
Em Vân thử chạy thì đối với các Folder con trong Folder với kết quả chuyển thành hết 1 Folder chung của các File mà không phải là mỗi Folder con có file nén được giải nén anh ạ !
 
Upvote 0
vanaccex đã viết:
Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
Nhấp chuột vào đây để mở rộng...
Em thử Sub này

Mã: 
Sub UnzipFiles()
Dim myfolder
Dim destfolder
 On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
 MsgBox "vanaccex can chon Folder chua cac file ZIP muon giai nen"
    .Show
    myfolder = .SelectedItems(1) & "\"
End With

With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "vanaccex chon Folder muon luu file giai nen "
    .Show
    destfolder = .SelectedItems(1) & "\"
End With

Call Recursive(myfolder, destfolder)
MsgBox "Da giai nen xong!"
End Sub

Sub Recursive(FolderPath As Variant, destfolder As Variant)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
Dim SApp As Object

ReDim Folders(0)

If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)

Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
            Folders(UBound(Folders)) = Value
            ReDim Preserve Folders(UBound(Folders) + 1)
        Else
            If Right(Value, 4) = ".zip" Then
                Set SApp = CreateObject("Shell.Application")
                SApp.Namespace(destfolder).CopyHere _
                SApp.Namespace(FolderPath & Value).items
            End If
        End If
    End If
    Value = Dir
Loop

For Each Folder In Folders
    Call Recursive(FolderPath & Folder & "\", destfolder)
Next Folder

End Sub
 

File đính kèm

  • Nen file.xlsb
    18 KB · Đọc: 8
Upvote 0
HeSanbi đã viết:
Bạn copy và thử lại xem
Nhấp chuột vào đây để mở rộng...
Dạ em Vân thử với ! Folder cho 5 Folder con ( có khoảng 6 file né ở trong) + 10 File nén ở ngoài . Chạy lại Đoạn code đó mà nó gộp thành 40 File ra ngoài hết anh ạ !
Bài đã được tự động gộp:

LamNA đã viết:
Em thử Sub này

Mã: 
Sub UnzipFiles()
Dim myfolder
Dim destfolder
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "vanaccex can chon Folder chua cac file ZIP muon giai nen"
    .Show
    myfolder = .SelectedItems(1) & "\"
End With

With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "vanaccex chon Folder muon luu file giai nen "
    .Show
    destfolder = .SelectedItems(1) & "\"
End With

Call Recursive(myfolder, destfolder)
MsgBox "Da giai nen xong!"
End Sub

Sub Recursive(FolderPath As Variant, destfolder As Variant)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
Dim SApp As Object

ReDim Folders(0)

If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)

Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
            Folders(UBound(Folders)) = Value
            ReDim Preserve Folders(UBound(Folders) + 1)
        Else
            If Right(Value, 4) = ".zip" Then
                Set SApp = CreateObject("Shell.Application")
                SApp.Namespace(destfolder).CopyHere _
                SApp.Namespace(FolderPath & Value).items
            End If
        End If
    End If
    Value = Dir
Loop

For Each Folder In Folders
    Call Recursive(FolderPath & Folder & "\", destfolder)
Next Folder

End Sub

Em Vân thử mà vẫn chưa được như ý muốn là Giải nén được cả các File trong các Folder con anh ạ
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Upvote 0
vanaccex đã viết:
Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
Nhấp chuột vào đây để mở rộng...
Bạn thử xem. Chỉ áp dụng cho file .zip nhé.
 

File đính kèm

  • UnzipAllFiles.xlsm
    17.9 KB · Đọc: 24
Upvote 0
vanaccex đã viết:
Dạ vâng em Vân cảm ơn anh @huuthang_bd ạ. ! Anh có thể giúp em Vân loại trừ không giải nén các File có đuôi KRAB không giải nén không ạ !
Nhấp chuột vào đây để mở rộng...
Tức thế nào? Nên tập nói rõ, cả câu.

Nhiều người hay dùng từ đuôi để ám chỉ định dạng: xlsx, xls, xlsm, doc, docx, jpg, gif, avi, mp3, exe, dll, bat ... Bạn cũng dùng từ đuôi nhưng có lẽ không ám chỉ định dạng. Lần sau nên nói rõ.

Nếu bạn muốn bung các tập tin có tên là "...ZIP" nhưng không phải là "...KRAB.ZIP"? Nếu thế thì đọc tiếp.

- code dưới không tạo thêm các thư mục con. Code của huuthang_bd tạo thêm thư mục con. vd. trong thư mục có anh.zip là tập tin nén của anh.jpg thì sau khi chạy code trong thư mục có thư mục con anh, và trong thư mục con anh mới có anh.jpg.
- code sẽ lưu thư mục cũ với tên <tên cũ>_<ngay, tháng, năm, gio, phút, giây>. Tức khi cần thì luôn có bản lưu.
- với các code của huuthang_bd, LamNA và của tôi thì mọi tập tin ZIP mà trong đường dẫn có ký tự unicode sẽ không được bung.
- macro để gán cho nút là DoExtractZip
Mã: 
Sub DoExtractZip()
'    Cac tap tin ZIP co duong dan unicode se khong duoc bung ra
Dim FolderStart As String, fso As Object, shellObj As Object
    MsgBox "Hay chon thu muc bat dau"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            FolderStart = .SelectedItems(1)
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set shellObj = CreateObject("Shell.Application")
            fso.CopyFolder FolderStart, FolderStart & Format(Now, "_ddmmyyyyhhmmss")
            ExtractZip FolderStart, fso, shellObj
            Set fso = Nothing
            Set shellObj = Nothing
            MsgBox "Done"
        End If
    End With
End Sub

Public Sub ExtractZip(ByVal FolderStart As String, fso As Object, shellObj)
Dim f As Object, SubF As Object
    Set f = fso.GetFolder(FolderStart)
    For Each SubF In f.files
        If LCase(SubF.Name) Like "*.zip" And Not LCase(SubF.Name) Like "*krab.zip" Then
            shellObj.Namespace(f & "\").CopyHere shellObj.Namespace(FolderStart & "\" & SubF.Name).items
            fso.DeleteFile FolderStart & "\" & SubF.Name
        End If
    Next SubF
    For Each SubF In f.SubFolders
        ExtractZip SubF.Path, fso, shellObj
    Next
    
    Set f = Nothing
End Sub
 
Upvote 0
batman1 đã viết:
Tức thế nào? Nên tập nói rõ, cả câu.

Nhiều người hay dùng từ đuôi để ám chỉ định dạng: xlsx, xls, xlsm, doc, docx, jpg, gif, avi, mp3, exe, dll, bat ... Bạn cũng dùng từ đuôi nhưng có lẽ không ám chỉ định dạng. Lần sau nên nói rõ.

Nếu bạn muốn bung các tập tin có tên là "...ZIP" nhưng không phải là "...KRAB.ZIP"? Nếu thế thì đọc tiếp.

- code dưới không tạo thêm các thư mục con. Code của huuthang_bd tạo thêm thư mục con. vd. trong thư mục có anh.zip là tập tin nén của anh.jpg thì sau khi chạy code trong thư mục có thư mục con anh, và trong thư mục con anh mới có anh.jpg.
- code sẽ lưu thư mục cũ với tên <tên cũ>_<ngay, tháng, năm, gio, phút, giây>. Tức khi cần thì luôn có bản lưu.
- với các code của huuthang_bd, LamNA và của tôi thì mọi tập tin ZIP mà trong đường dẫn có ký tự unicode sẽ không được bung.
- macro để gán cho nút là DoExtractZip
Mã: 
Sub DoExtractZip()
'    Cac tap tin ZIP co duong dan unicode se khong duoc bung ra
Dim FolderStart As String, fso As Object, shellObj As Object
    MsgBox "Hay chon thu muc bat dau"
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            FolderStart = .SelectedItems(1)
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set shellObj = CreateObject("Shell.Application")
            fso.CopyFolder FolderStart, FolderStart & Format(Now, "_ddmmyyyyhhmmss")
            ExtractZip FolderStart, fso, shellObj
            Set fso = Nothing
            Set shellObj = Nothing
            MsgBox "Done"
        End If
    End With
End Sub

Public Sub ExtractZip(ByVal FolderStart As String, fso As Object, shellObj)
Dim f As Object, SubF As Object
    Set f = fso.GetFolder(FolderStart)
    For Each SubF In f.files
        If LCase(SubF.Name) Like "*.zip" And Not LCase(SubF.Name) Like "*krab.zip" Then
            shellObj.Namespace(f & "\").CopyHere shellObj.Namespace(FolderStart & "\" & SubF.Name).items
            fso.DeleteFile FolderStart & "\" & SubF.Name
        End If
    Next SubF
    For Each SubF In f.SubFolders
        ExtractZip SubF.Path, fso, shellObj
    Next
   
    Set f = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ vâng em Vân cảm ơn anh @batman1 nhiều ạ. Em Vân thành thật xin lỗi, Em Vân sẽ rút kinh nghiệm ạ.
Em Vân là muốn giải nén tất cả các File có đuôi là .zip kể cả File có đuôi KRAB.zip. Với File có đuôi KRAB.zip thì sau khi giải nén xong sẽ tiếp tục giải nén File có đuôi KRAB anh ạ
Với Đoạn code của Anh Thắng là do Em Vân bị lỗi đường dẫn quá dài nên nó báo vậy anh ạ
Em Vân cảm ơn các anh đã giúp đỡ em Vân rất nhiều ạ !
 
Upvote 0
Tôi nhầm một đoạn code. Bạn thử copy và làm lại lần nữa xem sao.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
12
Đọc
162
tsslump
T
A
[Góc giúp đỡ] Tìm kiếm, lọc và lấy dữ liệu từ nhiều file Word cấu trúc giống nhau vào 1 file excel mẫu
Trả lời
2
Đọc
49
anhgp1
A
T
  • Question
Ghép 2 cột dữ liệu
Trả lời
1
Đọc
22
Phuocam
Phuocam
N
Xin code tính tổng số cấu đúng viết trong "Visual Basic" trong PPT
Trả lời
1
Đọc
4K
hahuy_hien2000
H
8
Hàm thống kê số lượng thành viên câu lạc bộ theo từng đợt tuyển thành viên
Trả lời
3
Đọc
94
HieuCD
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom