Dùng Macro để đổi định dạng file hàng loạt (1 người xem)

  • Thread starter Thread starter MinhKhai
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
MinhKhai

MinhKhai

Giải pháp Ếc-xào
Tham gia
16/4/08
Bài viết
941
Được thích
574
Chào các anh chị

Em có đống dữ liệu dùng chung, được hình thành ngày qua ngày.
Mỗi ngày có khoảng 10-15 file được đặt trong 1 folder. Mỗi folder là 1 ngày lại được đặt trong 1 folder tháng. Tóm lại là mỗi tháng có khoảng 400 file trong 30 folder.
Các file hiện tại đều cùng cấu trúc và có đuôi .xlsb
Em muốn xóa macro khỏi các file đó để không ai kích hoạt lại chức năng của Macro trong nó. Em đang xóa macro bằng cách Save as ra .xlsx nhưng bằng cách hoàn toàn thủ công.
Mong các anh chị viết cho 1 đoạn code để chỉ 1 Click là các file được loại bỏ Macro (bằng cách Save as sang .xlsx)
Xin chân thành cảm ơn
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
MinhKhai đã viết:
Chào các anh chị

Em có đống dữ liệu dùng chung, được hình thành ngày qua ngày.
Mỗi ngày có khoảng 10-15 file được đặt trong 1 folder. Mỗi folder là 1 ngày lại được đặt trong 1 folder tháng. Tóm lại là mỗi tháng có khoảng 400 file trong 30 folder.
Các file hiện tại đều cùng cấu trúc và có đuôi .xlsb
Em muốn xóa macro khỏi các file đó để không ai kích hoạt lại chức năng của Macro trong nó. Em đang xóa macro bằng cách Save as ra .xlsx nhưng bằng cách hoàn toàn thủ công.
Mong các anh chị viết cho 1 đoạn code để chỉ 1 Click là các file được loại bỏ Macro (bằng cách Save as sang .xlsx)
Xin chân thành cảm ơn
Nhấp chuột vào đây để mở rộng...
Xóa code nhưng vẫn giữ định dạng .xlsb được không bạn? (Vì khi lưu sang xlsx thì phải mất công xóa file .xlsb) Tức là mở nó lên xóa hết code sau đó lưu lại file và đóng.
 
Upvote 0
giaiphap đã viết:
Xóa code nhưng vẫn giữ định dạng .xlsb được không bạn? (Vì khi lưu sang xlsx thì phải mất công xóa file .xlsb) Tức là mở nó lên xóa hết code sau đó lưu lại file và đóng.
Nhấp chuột vào đây để mở rộng...
Tôi nghĩ SaveAs sang XLSX rồi xóa file XLSB sẽ dễ hơn xóa code đấy. Bởi đã là code thì sẽ có ở khắp nơi: Trong sheet, trong Thisworkbook, trong UserForm, trong class và thậm chí là trong các name macro 4.... Đuối luôn đấy
 
Upvote 0
ndu96081631 đã viết:
Tôi nghĩ SaveAs sang XLSX rồi xóa file XLSB sẽ dễ hơn xóa code đấy. Bởi đã là code thì sẽ có ở khắp nơi: Trong sheet, trong Thisworkbook, trong UserForm, trong class và thậm chí là trong các name macro 4.... Đuối luôn đấy
Nhấp chuột vào đây để mở rộng...
Em thấy đoạn code này xóa rất dễ anh (Đã test), chỉ cần nâng cấp chút em nghĩ sẽ ngon cành đào.
http://www.vbaexpress.com/kb/getarticle.php?kb_id=93
 
Upvote 0
ndu96081631 đã viết:
Tôi nghĩ SaveAs sang XLSX rồi xóa file XLSB sẽ dễ hơn xóa code đấy. Bởi đã là code thì sẽ có ở khắp nơi: Trong sheet, trong Thisworkbook, trong UserForm, trong class và thậm chí là trong các name macro 4.... Đuối luôn đấy
Nhấp chuột vào đây để mở rộng...
Vâng bác. Ý em là có code này kích các file được mở rồi ép nó đóng lại bằng lệnh Save as .xlxs. Trường hợp không thể xóa file gốc có đuôi .xlsb thì em dùng Search của Windows để gom chúng lại rồi delete
Bác giúp em các Save as với.
 
Upvote 0
Upvote 0
giaiphap đã viết:
Xóa code nhưng vẫn giữ định dạng .xlsb được không bạn? (Vì khi lưu sang xlsx thì phải mất công xóa file .xlsb) Tức là mở nó lên xóa hết code sau đó lưu lại file và đóng.
Nhấp chuột vào đây để mở rộng...
Làm sao cũng được, miễn là xóa code bên trong.
Mình chỉ nghĩ cách xóa code nhanh và đơn giản bằng cách kích mở từng file trong thư mục chỉ định sau đó cho save as lại với file type là .xlxs. Cách này đơn giản nhưng mình chưa biết cách làm bằng Code
 
Upvote 0
MinhKhai đã viết:
Làm sao cũng được, miễn là xóa code bên trong.
Mình chỉ nghĩ cách xóa code nhanh và đơn giản bằng cách kích mở từng file trong thư mục chỉ định sau đó cho save as lại với file type là .xlxs. Cách này đơn giản nhưng mình chưa biết cách làm bằng Code
Nhấp chuột vào đây để mở rộng...
Đặt tất cả các file cần xóa code vào chung thư mục với file chứa code này và cho chạy code xem sao.
Mã: 
Sub DeleteAllCode()
On Error Resume Next
    Const ExcelExtension As String = "|xlsb|xlsm|"
    Dim Wb As Workbook
    Dim x As Integer
    Dim sFolder As String, iFile As Object, FullPath As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    With CreateObject("Scripting.FileSystemObject")
        sFolder = .GetParentFolderName(ThisWorkbook.FullName)
        For Each iFile In .GetFolder(sFolder).Files
            If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
                If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                Set Wb = Workbooks.Open(sFolder & "\" & iFile.Name)
                    With Wb.VBProject
                        For x = .VBComponents.Count To 1 Step -1
                            .VBComponents.Remove .VBComponents(x)
                        Next x
                        For x = .VBComponents.Count To 1 Step -1
                            .VBComponents(x).CodeModule.DeleteLines _
                            1, .VBComponents(x).CodeModule.CountOfLines
                        Next x
                    End With
                    Wb.Close True
                    Set Wb = Nothing
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    MsgBox "Da thuc hien xong", vbExclamation, "GPE!"
End Sub
 
Upvote 0
giaiphap đã viết:
Đặt tất cả các file cần xóa code vào chung thư mục với file chứa code này và cho chạy code xem sao.
Mã: 
Sub DeleteAllCode()
On Error Resume Next
    Const ExcelExtension As String = "|xlsb|xlsm|"
    Dim Wb As Workbook
    Dim x As Integer
    Dim sFolder As String, iFile As Object, FullPath As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    With CreateObject("Scripting.FileSystemObject")
        sFolder = .GetParentFolderName(ThisWorkbook.FullName)
        For Each iFile In .GetFolder(sFolder).Files
            If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
                If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                Set Wb = Workbooks.Open(sFolder & "\" & iFile.Name)
                    With Wb.VBProject
                        For x = .VBComponents.Count To 1 Step -1
                            .VBComponents.Remove .VBComponents(x)
                        Next x
                        For x = .VBComponents.Count To 1 Step -1
                            .VBComponents(x).CodeModule.DeleteLines _
                            1, .VBComponents(x).CodeModule.CountOfLines
                        Next x
                    End With
                    Wb.Close True
                    Set Wb = Nothing
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    MsgBox "Da thuc hien xong", vbExclamation, "GPE!"
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn đã dành thời gian
Mình đã thử xem sao nhưng code chạy rất lâu mà chưa biết kết quả. (khả năng bị treo)

Folder có chứa 16 file, mỗi file có dung lượng ~ 150KB, trong file có 1 modul và 2 Sub.
Lưu ý: Có đặt pass để xem được Code

Vậy bạn xem nguyên nhân gì mà Code lại không hoạt động như mong muốn. (Không biết có phải nó muốn xóa chính nó nên mắc lỗi không nhỉ)
Xin cảm ơn
 
Upvote 0
MinhKhai đã viết:
Cảm ơn bạn đã dành thời gian
Mình đã thử xem sao nhưng code chạy rất lâu mà chưa biết kết quả. (khả năng bị treo)

Folder có chứa 16 file, mỗi file có dung lượng ~ 150KB, trong file có 1 modul và 2 Sub.
Lưu ý: Có đặt pass để xem được Code

Vậy bạn xem nguyên nhân gì mà Code lại không hoạt động như mong muốn. (Không biết có phải nó muốn xóa chính nó nên mắc lỗi không nhỉ)
Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Bạn điều chỉnh dòng dưới cho phù hợp:
Const ExcelExtension As String = "|xlsb|xlsm|"
 
Upvote 0
phulien1902 đã viết:
Bạn điều chỉnh dòng dưới cho phù hợp:
Const ExcelExtension As String = "|xlsb|xlsm|"
Nhấp chuột vào đây để mở rộng...
Mình chưa hiểu gợi ý của bạn.
Lúc trước các file đều có đuôi .xlsb bao gồm cả file có code xóa. Sau đó mình chuyển file có code xóa sang .xlsm và thử chay cũng vẫn bị treo
Hướng dẫn thêm giúp mình nhé. Xin cảm ơn
 
Upvote 0
MinhKhai đã viết:
Cảm ơn bạn đã dành thời gian

Lưu ý: Có đặt pass để xem được Code
Vậy bạn xem nguyên nhân gì mà Code lại không hoạt động như mong muốn. (Không biết có phải nó muốn xóa chính nó nên mắc lỗi không nhỉ)
Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Chổ màu đỏ thì code không thực hiện được nhé bạn, code chỉ thực hiện trên file không đặt password vba Project. Vậy mở file lên và save lại định dạng xlsx thì sửa code như sau:
Mã: 
Sub DeleteAllCode()
On Error Resume Next
    Const ExcelExtension As String = "|xlsb|xlsm|"
    Dim Wb As Workbook
    Dim x As Integer
    Dim sFolder As String, iFile As Object, FullPath As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    With CreateObject("Scripting.FileSystemObject")
        sFolder = .GetParentFolderName(ThisWorkbook.FullName)
        MkDir sFolder & "\GPE"
        For Each iFile In .GetFolder(sFolder).Files
            If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
                If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                Set Wb = Workbooks.Open(sFolder & "\" & iFile.Name)
                    Wb.SaveAs Filename:=Left(sFolder & "\GPE\" & iFile.Name, Len(sFolder & "\GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
                    Wb.Close False
                    Set Wb = Nothing
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    MsgBox "Da thuc hien xong", vbExclamation, "GPE!"
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
MinhKhai đã viết:
Hiện tại các file đều được đặt pass xem code và mình có pass để xem.
Vậy có cách nào xử lý vấn đề này không bạn ??
Nhấp chuột vào đây để mở rộng...
MinhKhai đã viết:
Hiện tại các file đều được đặt pass xem code và mình có pass để xem.
Vậy có cách nào xử lý vấn đề này không bạn ??
Nhấp chuột vào đây để mở rộng...
Cái này mình chịu rồi bạn nhé, chưa hề tìm hiểu về nó.
 
Upvote 0
MinhKhai đã viết:
Mình chưa hiểu gợi ý của bạn.
Lúc trước các file đều có đuôi .xlsb bao gồm cả file có code xóa. Sau đó mình chuyển file có code xóa sang .xlsm và thử chay cũng vẫn bị treo
Hướng dẫn thêm giúp mình nhé. Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Hôm qua tôi quên không nói với bạn là trong các File của bạn không được khóa Code VBA.
 
Upvote 0
befaint đã viết:
Mình thử xóa cái vbaProject.bin thì code hết (trừ Macro4 trong name).
Trên GPE có bài về trích file để xử lý (...) không biết bài này áp dụng được không.

View attachment 195212
Nhấp chuột vào đây để mở rộng...
Có phải @befaint gợi ý đổi đuôi thủ công sang .zip sau đó giải nén và tìm xóa các vbaProject.bin ??
Có 2 vấn đề xảy ra
1. Mình thử mà không được
2. Vấn đề ban đầu mình muốn tự động để giảm thao tác thủ công, chứ nếu cứ mở thủ công và save as sang file .xlsx thì vấn đề giải quyết được ngay
Xin cảm ơn mọi người
 
Upvote 0
befaint đã viết:
Mình thử xóa cái vbaProject.bin thì code hết (trừ Macro4 trong name).
Trên GPE có bài về trích file để xử lý (...) không biết bài này áp dụng được không.

View attachment 195212
Nhấp chuột vào đây để mở rộng...
Muốn làm được chuyện này thì đầu tiên phải SaveAs sang XLSX. Mà khi đã SaveAs rồi thì mọi chuyện đã... xong và không cần làm thêm gì nữa cả
 
Upvote 0

File đính kèm

Upvote 0
giaiphap đã viết:
Chổ màu đỏ thì code không thực hiện được nhé bạn, code chỉ thực hiện trên file không đặt password vba Project. Vậy mở file lên và save lại định dạng xlsx thì sửa code như sau:
Mã: 
Sub DeleteAllCode()
On Error Resume Next
    Const ExcelExtension As String = "|xlsb|xlsm|"
    Dim Wb As Workbook
    Dim x As Integer
    Dim sFolder As String, iFile As Object, FullPath As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    With CreateObject("Scripting.FileSystemObject")
        sFolder = .GetParentFolderName(ThisWorkbook.FullName)
        MkDir sFolder & "\GPE"
        For Each iFile In .GetFolder(sFolder).Files
            If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
                If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                Set Wb = Workbooks.Open(sFolder & "\" & iFile.Name)
                    Wb.SaveAs Filename:=Left(sFolder & "\GPE\" & iFile.Name, Len(sFolder & "\GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
                    Wb.Close False
                    Set Wb = Nothing
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    MsgBox "Da thuc hien xong", vbExclamation, "GPE!"
End Sub
Nhấp chuột vào đây để mở rộng...
Anh cho em hỏi code trên khi chạy thì nó tạo ra thư mục mới là GPE và nó lưu những file đã xóa code
Bây giờ em muốn những file đã xóa code vẫn lưu ở thư mục củ được không anh? Em cảm ơn!
 
Upvote 0
AnhThu-1976 đã viết:
Anh cho em hỏi code trên khi chạy thì nó tạo ra thư mục mới là GPE và nó lưu những file đã xóa code
Bây giờ em muốn những file đã xóa code vẫn lưu ở thư mục củ được không anh? Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Thay dòng
Mã: 
Wb.SaveAs Filename:=Left(sFolder & "\GPE\" & iFile.Name, Len(sFolder & "\GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
thành
Mã: 
Wb.SaveAs Filename:=Left(sFolder & "\" & iFile.Name, Len(sFolder & "\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
 
Upvote 0
giaiphap đã viết:
Thay dòng
Mã: 
Wb.SaveAs Filename:=Left(sFolder & "\GPE\" & iFile.Name, Len(sFolder & "\GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
thành
Mã: 
Wb.SaveAs Filename:=Left(sFolder & "\" & iFile.Name, Len(sFolder & "\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh, bây giờ mình muốn nó xóa luôn File có code (trừ file chứa code
Sub DeleteAllCode() ) để chuyển file cho khách hàng đỡ lẫn lộn
 
Upvote 0
AnhThu-1976 đã viết:
Cảm ơn anh, bây giờ mình muốn nó xóa luôn File có code (trừ file chứa code
Sub DeleteAllCode() ) để chuyển file cho khách hàng đỡ lẫn lộn
Nhấp chuột vào đây để mở rộng...
Thì như ban đầu cho lưu vào một thư mục có tên GPE xong gửi thư mục GPE đó đi là xong.
 
Upvote 0
giaiphap đã viết:
Thì như ban đầu cho lưu vào một thư mục có tên GPE xong gửi thư mục GPE đó đi là xong.
Nhấp chuột vào đây để mở rộng...
Thường thư mục của em là ngay-tháng -năm, nên khi giở cho khách hàng thì người thực thi họ chỉ cần nhìn tên thư mục là họ chuyển File
Do đó nếu để vậy thì họ khó xác định được tên thư mục
Nếu được thì anh giúp em, còn phức tạp quá thì thôi anh ạ, em cảm ơn!
 
Upvote 0
AnhThu-1976 đã viết:
Thường thư mục của em là ngay-tháng -năm, nên khi giở cho khách hàng thì người thực thi họ chỉ cần nhìn tên thư mục là họ chuyển File
Do đó nếu để vậy thì họ khó xác định được tên thư mục
Nếu được thì anh giúp em, còn phức tạp quá thì thôi anh ạ, em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Thì chổ GPE bạn sửa thành gì đó do bạn. Còn không nửa bạn đổi tên trước khi gửi. Còn nửa là tạo thư mục theo ngày tháng năm hiện tại bằng code luôn.
 
Upvote 0
Hoặc có phương án như thế này
Vẫn tạo thư mục mới nhưng ghép tên thư mục cha & GPE
ví dụ thư mục cha là 2807 (ngày tháng dạng "ddmm" thì ghép nó thành 2807GPE
giaiphap đã viết:
. Còn nửa là tạo thư mục theo ngày tháng năm hiện tại bằng code luôn.
Nhấp chuột vào đây để mở rộng...
Nếu được thì anh giúp em cách này cũng được (lưu ý thư mục cha đã là 2807 (ngày tháng dạng "ddmm")Mong anh giúp em
 
Upvote 0
AnhThu-1976 đã viết:
Hoặc có phương án như thế này
Vẫn tạo thư mục mới nhưng ghép tên thư mục cha & GPE
ví dụ thư mục cha là 2807 (ngày tháng dạng "ddmm" thì ghép nó thành 2807GPE

Nếu được thì anh giúp em cách này cũng được (lưu ý thư mục cha đã là 2807 (ngày tháng dạng "ddmm")Mong anh giúp em
Nhấp chuột vào đây để mở rộng...
Dùng thử vầy.
Mã: 
Wb.SaveAs Filename:=Left(sFolder & Format(Now, "ddmm") & "GPE\" & iFile.Name, Len(sFolder & Format(Now, "ddmm") & "GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
 
Upvote 0
giaiphap đã viết:
Dùng thử vầy.
Mã: 
Wb.SaveAs Filename:=Left(sFolder & Format(Now, "ddmm") & "GPE\" & iFile.Name, Len(sFolder & Format(Now, "ddmm") & "GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
Nhấp chuột vào đây để mở rộng...
Em chưa thử nhưng thấy code trên nó lấy ngày hiện tại thì phải
Mã: 
& Format(Now, "ddmm")
Thực tế thì công việc có thể ngày nào làm ngày đó thì code trên thì đúng, nhưng nhiều lúc ngày hôm sau mới làm thì tên thư mục nó không còn đúng nữa
Em nghỉ lấy tên thư mục cha ghép vào thì được hơn đó anh. Em cảm ơn!
 
Upvote 0
AnhThu-1976 đã viết:
Em chưa thử nhưng thấy code trên nó lấy ngày hiện tại thì phải
Mã: 
& Format(Now, "ddmm")
Thực tế thì công việc có thể ngày nào làm ngày đó thì code trên thì đúng, nhưng nhiều lúc ngày hôm sau mới làm thì tên thư mục nó không còn đúng nữa
Em nghỉ lấy tên thư mục cha ghép vào thì được hơn đó anh. Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Nếu muốn lấy tên từ một ô A1 nào đó trong Sheet ABC thì sửa lại thế này.
Mã: 
Wb.SaveAs Filename:=Left(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name, Len(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkboo
 
Upvote 0
giaiphap đã viết:
Nếu muốn lấy tên từ một ô A1 nào đó trong Sheet ABC thì sửa lại thế này.
Mã: 
Wb.SaveAs Filename:=Left(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name, Len(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkboo
Nhấp chuột vào đây để mở rộng...
A cho em hỏi cái sheet ABC nó ở file nào vậy anh? file chạy code có code Sub DeleteAllCode() hay các file bị xóa code
Tất cả các file bị xóa code đều có 1 đặc điểm chung là tất cả đều có 1 tên sheet "Báo cáo" và trên sheet này tại ô C2 là ngày và ô E2 là tháng
Bài đã được tự động gộp:

Em có để sheet ABC trong file chứa Sub DeleteAllCode()
nhưng khi chạy code thì bị lỗi, nhờ anh tải file xuống và test
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
AnhThu-1976 đã viết:
A cho em hỏi cái sheet ABC nó ở file nào vậy anh? file chạy code có code Sub DeleteAllCode() hay các file bị xóa code
Tất cả các file bị xóa code đều có 1 đặc điểm chung là tất cả đều có 1 tên sheet "Báo cáo" và trên sheet này tại ô C2 là ngày và ô E2 là tháng
Bài đã được tự động gộp:

Em có để sheet ABC trong file chứa Sub DeleteAllCode()
nhưng khi chạy code thì bị lỗi, nhờ anh tải file xuống và test
Nhấp chuột vào đây để mở rộng...

Đã tìm ra nguyên nhân code bị lỗi là do thiếu chữ k trong
Mã: 
FileFormat:=xlOpenXMLWorkboo
Nhưng code vẫn không tạo được thư mục
 
Upvote 0
giaiphap đã viết:
Nếu muốn lấy tên từ một ô A1 nào đó trong Sheet ABC thì sửa lại thế này.
Mã: 
Wb.SaveAs Filename:=Left(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name, Len(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkboo
Nhấp chuột vào đây để mở rộng...
Em đã tạo được thư mục theo ô A1 nào đó trong Sheet ABC
Mã: 
MkDir sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE"
Nhưng em dùng code của anh
Mã: 
Wb.SaveAs Filename:=Left(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name, Len(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkboo
để nó lưu file .xlsx vào thư mục trên thì chưa lưu được
Cụ thể code em sau khi chỉnh
Mã: 
Sub DeleteAllCode()
    On Error Resume Next
    Const ExcelExtension As String = "|xlsb|xlsm|"
    Dim Wb As Workbook
    Dim x As Integer
    Dim sFolder As String, iFile As Object, FullPath As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    With CreateObject("Scripting.FileSystemObject")
        sFolder = .GetParentFolderName(ThisWorkbook.FullName)
        MkDir sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE"
        For Each iFile In .GetFolder(sFolder).Files
            If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
                If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                    Set Wb = Workbooks.Open(sFolder & "\" & iFile.Name)
                    Wb.SaveAs Filename:=Left(sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE" & "\" & iFile.Name, Len(sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE" & "\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
                    Wb.Close False
                    Set Wb = Nothing
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    MsgBox "Da thuc hien xong", vbExclamation, "NopBaoCao!"
End Sub
Anh chị vui lòng sửa code giúp em! Em cảm ơn.
 
Upvote 0
AnhThu-1976 đã viết:
Em đã tạo được thư mục theo ô A1 nào đó trong Sheet ABC
Mã: 
MkDir sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE"
Nhưng em dùng code của anh
Mã: 
Wb.SaveAs Filename:=Left(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name, Len(sFolder & Sheets("ABC").Range("A1").Value & "GPE\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkboo
để nó lưu file .xlsx vào thư mục trên thì chưa lưu được
Cụ thể code em sau khi chỉnh
Mã: 
Sub DeleteAllCode()
    On Error Resume Next
    Const ExcelExtension As String = "|xlsb|xlsm|"
    Dim Wb As Workbook
    Dim x As Integer
    Dim sFolder As String, iFile As Object, FullPath As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    With CreateObject("Scripting.FileSystemObject")
        sFolder = .GetParentFolderName(ThisWorkbook.FullName)
        MkDir sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE"
        For Each iFile In .GetFolder(sFolder).Files
            If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
                If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                    Set Wb = Workbooks.Open(sFolder & "\" & iFile.Name)
                    Wb.SaveAs Filename:=Left(sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE" & "\" & iFile.Name, Len(sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE" & "\" & iFile.Name) - 4) & "xlsx", FileFormat:=xlOpenXMLWorkbook
                    Wb.Close False
                    Set Wb = Nothing
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    MsgBox "Da thuc hien xong", vbExclamation, "NopBaoCao!"
End Sub
Anh chị vui lòng sửa code giúp em! Em cảm ơn.
Nhấp chuột vào đây để mở rộng...
Up file thực tế của bạn lên đây mình xem thử.
 
Upvote 0

File đính kèm

Upvote 0
AnhThu-1976 đã viết:
Gởi Anh 2 File
File XoaCode dùng xóa code còn file còn lại là bị xóa code và lưu vào thư mục mới
Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Dùng code này.
Mã: 
Sub DeleteAllCode()
    'On Error Resume Next
    Const ExcelExtension As String = "|xlsb|xlsm|"
    Dim Wb As Workbook, s$, sFile$
    Dim x As Integer
    Dim sFolder As String, iFile As Object, FullPath As String
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    With CreateObject("Scripting.FileSystemObject")
        sFolder = .GetParentFolderName(ThisWorkbook.FullName)
        s = sFolder & "\" & Sheets("ABC").Range("A1").Value & "GPE"
        If Not .FolderExists(s) Then
             .CreateFolder (s)
        End If
        For Each iFile In .GetFolder(sFolder).Files
            If InStr(ExcelExtension, "|" & .GetExtensionName(iFile.Path) & "|") > 0 Then
                If iFile.Path <> ThisWorkbook.FullName And Left(iFile.Name, 2) <> "~$" Then
                    Set Wb = Workbooks.Open(sFolder & "\" & iFile.Name)
                    sFile = s & "\" & .GetBaseName(iFile)
                    Wb.SaveAs Filename:=sFile & "xlsx", FileFormat:=xlOpenXMLWorkbook
                    Wb.Close False
                End If
            End If
        Next
    End With
    Set Wb = Nothing
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    MsgBox "Da thuc hien xong", vbExclamation, "NopBaoCao!"
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

B
Mình có làm đoạn code VBA trong file access mà cứ báo lỗi nhờ mọi người hướng dẫn (2 người xem)
Trả lời
2
Đọc
70
ongke0711
ongke0711
thanhss
Tự động lấy dữ liệu từ các sheet khác đưa vào sheet tổng hợp khi chọn Ngày hoặc tháng hoặc năm (6 người xem)
Trả lời
14
Đọc
175
Hoàng Tuấn 868
H
vuthaiha90
Lọc dữ liệu không trùng và trả kết quả về 1 dòng (1 người xem)
Trả lời
7
Đọc
257
tranhungdao12a3
T
Tuanba1992
Lập trình Excel có thể dùng ngôn ngữ lập trình nào? (4 người xem)
Trả lời
2
Đọc
144
nguyendang95
N
H
Tổng hợp Công Nợ theo Công trình (6 người xem)
Trả lời
26
Đọc
290
DeTong
D
T
Nhờ anh chị xem giúp file bị lỗi gì mà chạy rất chậm/lag - File tính tiền nhà trọ
Trả lời
10
Đọc
377
Thaik05
T
Nguyễn Duy Tuân
Hàm BS COMBINLIST Liệt kê các giá trị tổ hợp, chỉnh hợp, chỉnh hợp không lặp | Add-in A-Tools v10 (1 người xem)
    • Yêu thích
    • Thích
Trả lời
24
Đọc
2K
nguyendang95
N
J
Xử lý các file Excel bị nặng sau nhiều năm sử dụng
Trả lời
13
Đọc
2K
huhumalu
H
hongphuong1997
Nên sử dụng Chatgpt hay Copilot (3 người xem)
    • Yêu thích
Trả lời
12
Đọc
328
phuongnam366377
phuongnam366377
L
File Excel nặng chưa tìm được lý do ở đâu . Mong các bác hỗ trợ !
Trả lời
5
Đọc
129
PhanTuHuong
PhanTuHuong
U
VB tính tổng số cell trong 1 hàng có cùng màu với 1 cell so sánh ở cột khác (1 người xem)
Trả lời
5
Đọc
87
Hoàng Tuấn 868
H
T
VBA LẤY THÔNG TIN TRÊN TỜ KHAI NHẬP KHẨU (3 người xem)
Trả lời
10
Đọc
639
binhminh1408
B
H
Giúp mình ghép nhiều file thành một file. (3 người xem)
Trả lời
10
Đọc
446
hanhnguyen120221cuty
H
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD (1 người xem)
    • Thích
Trả lời
18
Đọc
1K
Hoàng Tuấn 868
H
HeSanbi
  • Đã giải quyết
ZaloExcel v2.96: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
60
Đọc
20K
HeSanbi
HeSanbi
D
XIN HỖ TRỢ VỀ FILE EXCEL TỔNG HỢP ĐIỂM THI ĐUA
Trả lời
0
Đọc
59
DươngH193
D
L
Xin file lịch báo giảng tự động (3 người xem)
Trả lời
2
Đọc
128
linedraw84
L
H
Xin File Theo dõi công nợ (3 người xem)
Trả lời
0
Đọc
101
HangktGTN
H
N
Tạo file Excel dùng VBA để lấy và nối dữ liệu từ các files excel (1 người xem)
Trả lời
39
Đọc
7K
hungnv_thct2026
H
S
Power BI. Một quá trình đòi hỏi sự kiên nhẫn.
Trả lời
4
Đọc
252
SteveNguyen1991
S
Xem thêm…

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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom