[Help]-Gộp nhiều file thành 1 file, tên file Tiếng Việt

keithchen

Thành viên mới
Hi mọi người! mình là newbie

Mình muốn dùng VBA gộp nhiều file Excel thành 1 file duy nhất. Mình lên mạng tìm hiểu thì ra được đoạn code này:

Mã:
Sub GetSheets()

    Dim path As String

    Dim wb As Workbook

    Dim sh As Worksheet

    path = "C:\Users\kei\Desktop\gopfile\"

    Filename = Dir(path & "*.xlsx")

    Application.ScreenUpdating = False

    Dim s As Integer

    Do While Filename <> ""

        Set wb = Workbooks.Open(Filename:=path & Filename, ReadOnly:=True)

        For Each sh In wb.Sheets

            s = s + 1

            sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = wb.Name & s

        Next sh

        wb.Close

        Filename = Dir()

    Loop

    Application.ScreenUpdating = True

    MsgBox "Done"

End Sub
code trên chạy ngon lành, gộp được tất cả các file trong thư mục "gopfile" thành 1 file.

Nhưng khi mình sửa lại đường dẫn "C:\Users\kei\Desktop\gopfile\" thành "C:\Users\kei\Desktop\gộp file\" hoặc tên file có chứa kí tự Tiếng Việt thì VBA báo lỗi vì không hiểu được kí tự Unicode.

Đây là dòng lỗi khi em run ạ:
"Run-time error '1004: Sorry, we couldn't find C:WUsersVPcVDesktoplfopfile\????-??????(1).xlsx. Is it possible it was moved, renamed or deleted?"

Có bác nào có giải pháp không ạ?
 
Sửa lần cuối:

Ngày Mới

Thành viên tích cực
Lưu ý với bạn: Code phải được đặt trong thẻ code, không để code và chữ tràng giang đại hải như thế.

Về chủ đề, để có thể sửa lỗi đường dẫn Tiếng Việt trong VBA, bạn phải dùng đường dẫn dưới dạng Sort thì sẽ hết lỗi này. Cụ thể, hãy sửa code lại như thế này thì bạn sẽ hết bị lỗi:
Mã:
Sub GetSheets()
Dim path As String
Dim wb As Workbook
Dim sh As Worksheet
'//DAY LA KHAI BAO FSO
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")

'//INPUT
path = "C:\Users\admin\OneDrive\Desktop\New folder\"
Filename = Dir(path & "*.xlsx")

'//PROCESS
path = FSO.GetFolder(path).ShortPath & "\"   '//DAY LA CODE THEM VAO DE XU LY LINK TIENG VIET
Application.ScreenUpdating = False
Dim s As Integer
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=path & Filename, ReadOnly:=True)
For Each sh In wb.Sheets
s = s + 1
sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = wb.Name & s
Next sh
wb.Close
Filename = Dir()
Loop
Application.ScreenUpdating = True

'//NOTIFICATION
MsgBox "Done"
End Sub
 

keithchen

Thành viên mới
Lưu ý với bạn: Code phải được đặt trong thẻ code, không để code và chữ tràng giang đại hải như thế.

Về chủ đề, để có thể sửa lỗi đường dẫn Tiếng Việt trong VBA, bạn phải dùng đường dẫn dưới dạng Sort thì sẽ hết lỗi này. Cụ thể, hãy sửa code lại như thế này thì bạn sẽ hết bị lỗi:
Mã:
Sub GetSheets()
Dim path As String
Dim wb As Workbook
Dim sh As Worksheet
'//DAY LA KHAI BAO FSO
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")

'//INPUT
path = "C:\Users\admin\OneDrive\Desktop\New folder\"
Filename = Dir(path & "*.xlsx")

'//PROCESS
path = FSO.GetFolder(path).ShortPath & "\"   '//DAY LA CODE THEM VAO DE XU LY LINK TIENG VIET
Application.ScreenUpdating = False
Dim s As Integer
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=path & Filename, ReadOnly:=True)
For Each sh In wb.Sheets
s = s + 1
sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = wb.Name & s
Next sh
wb.Close
Filename = Dir()
Loop
Application.ScreenUpdating = True

'//NOTIFICATION
MsgBox "Done"
End Sub
Cám ơn bạn rất nhiều <3
 

keithchen

Thành viên mới
Lưu ý với bạn: Code phải được đặt trong thẻ code, không để code và chữ tràng giang đại hải như thế.

Về chủ đề, để có thể sửa lỗi đường dẫn Tiếng Việt trong VBA, bạn phải dùng đường dẫn dưới dạng Sort thì sẽ hết lỗi này. Cụ thể, hãy sửa code lại như thế này thì bạn sẽ hết bị lỗi:
Mã:
Sub GetSheets()
Dim path As String
Dim wb As Workbook
Dim sh As Worksheet
'//DAY LA KHAI BAO FSO
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")

'//INPUT
path = "C:\Users\admin\OneDrive\Desktop\New folder\"
Filename = Dir(path & "*.xlsx")

'//PROCESS
path = FSO.GetFolder(path).ShortPath & "\"   '//DAY LA CODE THEM VAO DE XU LY LINK TIENG VIET
Application.ScreenUpdating = False
Dim s As Integer
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=path & Filename, ReadOnly:=True)
For Each sh In wb.Sheets
s = s + 1
sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = wb.Name & s
Next sh
wb.Close
Filename = Dir()
Loop
Application.ScreenUpdating = True

'//NOTIFICATION
MsgBox "Done"
End Sub
Bạn ơi, mình dùng code của bạn, nhưng vẫn báo lỗi cũ. 😞
tên file của mình dạng: "test tiếng việt 04.2122.xlsx"

Bạn cần đăng nhập để thấy hình ảnh
 

NhanSu

Thành Viên Nổi Bật

FileSystemObject làm việc được với tên file và đường dẫn có dấu tiếng Việt. Tuy nhiên khi sử dụng filename kết hợp với Workbooks.Open sẽ lỗi với tên file tiếng Việt do filename đã bị thay bằng dấu ?. Do vậy bạn cần sửa lại đoạn code như sau: vào Tools - Reference - chọn Microsoft scripting runtime
Mã:
Sub a()
    Dim str$, fso As New FileSystemObject, f As File, wb As Workbook
    str = [A1]  'path in cell A1
    For Each f In fso.GetFolder(str).Files
        If fso.GetExtensionName(f) Like "xls*" Then
            Set wb = Workbooks.Open(f)
            wb.Close False
        End If
    Next
End Sub
Chú ý lệnh ở dòng 6, nếu thay bằng Worbooks.Open(f.Name) sẽ bị lỗi khi tên file tiếng Việt, vì vậy cần dùng Worbooks.Open(f). Bạn tự bổ sung các lệnh để copy sheet nhé.
 

Ngày Mới

Thành viên tích cực
Dựa trên code của NhanSu, Tôi chế cháo lại một chút code cho bạn
Mã:
Sub GetSheets()
Dim wb As Workbook
Dim sh As Worksheet
Dim str As String
Dim f As File
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")

'//INPUT
str = "C:\Users\admin\OneDrive\Desktop\New folder\"

'//PROCESS
Application.ScreenUpdating = False
For Each f In fso.GetFolder(str).Files
    If fso.GetExtensionName(f) Like "xls*" Then
    
        Set wb = Workbooks.Open(f)
        For Each sh In wb.Sheets
            s = s + 1
            sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = wb.Name & s
        Next sh
        
        wb.Close False
        
    End If
Next
Application.ScreenUpdating = True
    
'//NOTIFICATION
MsgBox "Done"
End Sub
 
Top