Dùng Macro để đổi định dạng file hàng loạt

Liên hệ QC
MinhKhai

MinhKhai

Giải pháp Ếc-xào
Tham gia
16/4/08
Bài viết
937
Được thích
571
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

File đính kèm

  • TaoMenuMacro4.xlsb
    10.2 KB · Đọc: 16
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

  • XoaCode.xlsm
    17.6 KB · Đọc: 1
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
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.
Web KT

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

dovanha1994
Giúp e tìm nguyên nhân sai và hướng dẫn e đọc file này với ạ
    • Phẫn nộ
Trả lời
2
Đọc
25
hoangtuaotrang_hp_vn
H
K
Nhờ mọi người hoàn thiện giúp công thức
Trả lời
1
Đọc
29
hoangtuaotrang_hp_vn
H
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
10
Đọc
149
Parabol
P
N
Giúp sửa mã code
Trả lời
18
Đọc
367
truongvu317
truongvu317
CodyPham97
tạo biểu tượng thay thế nhấn đúp chuột
Trả lời
1
Đọc
31
BuiQuangThuan
B
H
Chúc mừng 20/11- ngày tôn vinh nhà giáo Việt Nam.
    • Thích
    • Yêu thích
Trả lời
0
Đọc
29
HUONGHCKT
H
triplet123
dạ em nhờ mọi người giúp em với ạ
    • Phẫn nộ
Trả lời
0
Đọc
33
triplet123
triplet123
F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
4
Đọc
427
hoangtuan.net
hoangtuan.net
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
7
Đọc
182
Ny Ny 2024
N
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
9
Đọc
447
bibuzz90
B
Nhật Anh 9x
  • Question
Tính tồn cuối kỳ luỹ kế cho nhiều mã
Trả lời
2
Đọc
80
Nhật Anh 9x
Nhật Anh 9x
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
1
Đọc
68
bebo021999
B
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
2
Trả lời
20
Đọc
546
ptm0412
ptm0412
nguyen trung cuong
File chứa marco không mở được.
Trả lời
2
Đọc
66
nguyen trung cuong
nguyen trung cuong
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
1
Đọc
103
hvnhpro
H
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
2
Đọc
63
bebo021999
B
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
37
Đọc
2K
cantl
C
triplet123
GIÚP EM VỚI Ạ EM CẢM ƠN MỌI NGƯỜI NHIỀU Ạ
    • Phẫn nộ
Trả lời
2
Đọc
96
DeTong
D
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
31
Đọc
798
Tuấn Bụng Bự
Tuấn Bụng Bự
S
  • Question
Xin file excel bảng giá quần áo, trang phục, phụ kiện
Trả lời
2
Đọc
74
VetMini
V
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

Back
Top Bottom