[Nhờ giúp đỡ] code vba đóng file, sửa tên file, mở lại file

[Ngày mai trời lại sáng]

Chào mọi người
Hiện giờ em đang có nhiều file link đến file có tên "A.xlsm" (tất cả các file cùng để chung vào một folder) , nhưng file "A.xlsm" này thường xuyên bị đổi tên theo ngày tháng năm hoặc tên khác không theo quy định nào.
Nhờ mọi người giúp em(cháu) một đoạn code mở file A này lên kiểm tra nếu không file tên "A.xlsm" sẽ đóng lại và sửa tên đúng với "A.xlsm" rồi mở lại file để các file đang mở cùng file "A.xlsm" có thể link được đến file "A.xlsm" .

 

[ongke0711]

"ngày mai em đi.xlsm" là code cháu sẽ đưa vào đây và sẽ nói với cho người sở hữu file "ngày mai em đi.xlsm" này là cháu phải làm vậy, bởi vì mỗi là họ cập nhật thay đổi dữ liệu vào là họ lại phải sửa và gửi tên khác, do đó mà dữ liệu nội dung bên trong là khác với nội dung file cũ.Ví dụ danh sách ca mắc codVid vẫn là file đó hôm nay nội dung khác ngày mai có thể sẽ khác và có thể không khác chỉ khác cái tên .
Cháu từ bài 1 đến bài này chưa thay đổi quan điểm hay ý tưởng,tất cả cháu đã tóm gọn lại ở đây, cháu không thay đôi:

Nếu làm cách này thì bạn nghĩ sao?
Không cần quan tâm đổi tên file vì nội dung thiết kế bên trong là giống nhau, chỉ khác nhau nội dung dữ liệu. Do đó, chỉ cần thêm các cột để phân biệt nội dung mới và cũ như: thêm cột ngày giờ cập nhật, cố định ở ô"A1", khi có sự thay đổi dữ liệu thì người nhập liệu nhập thông tin cho ô A1 này hoặc viết code tự động cập nhật ngày giờ khi có thay đổi.
Từ file xử lý của bạn, có thể kết nối, kiểm tra ô "A1" của file dữ liệu trên để biết nó là mới hay cũ rồi thực hiện các bước xử lý tiếp theo.

 

[batman1]

Thôi tôi làm theo cách hiểu của mình. Lời qua tiếng lại quá mất thời gian.

Option Explicit

Sub doi_ten()
Dim filename As String, myFullName As String, wb As Workbook, fso As Object
    If LCase(ThisWorkbook.Name) <> "nguon.xlsm" Then    ' neu tap tin hien hanh khong phai la nguon.xlsm thi thuc hien
        For Each wb In Application.Workbooks    ' duyet tung tap tin dang mo va neu gap tap tin nguon.xlsm thi dong va ra khoi FOR
            If LCase(wb.Name) = "nguon.xlsm" Then
                wb.Close True
                Exit For
            End If
        Next wb
        myFullName = ThisWorkbook.FullName  ' ten day du cua tap tin co code dang duoc thuc thi
        filename = ThisWorkbook.Path & "\nguon.xlsm"    ' ten day du cua tap tin nguon.xlsm
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filename) Then fso.DeleteFile filename, True  ' neu ton tai tap tin ... nguon.xlsm thi xoa
        ThisWorkbook.SaveAs filename    ' ghi tap tin hien hanh voi ten nguon.xlsm
        fso.DeleteFile myFullName   ' xoa tap tin cu sau khi luu voi ten moi la nguon.xlsm
        Set fso = Nothing
    End If
End Sub

 

[Ngày mai trời lại sáng]

Thôi tôi làm theo cách hiểu của mình. Lời qua tiếng lại quá mất thời gian.

Option Explicit

Sub doi_ten()
Dim filename As String, myFullName As String, wb As Workbook, fso As Object
    If LCase(ThisWorkbook.Name) <> "nguon.xlsm" Then    ' neu tap tin hien hanh khong phai la nguon.xlsm thi thuc hien
        For Each wb In Application.Workbooks    ' duyet tung tap tin dang mo va neu gap tap tin nguon.xlsm thi dong va ra khoi FOR
            If LCase(wb.Name) = "nguon.xlsm" Then
                wb.Close True
                Exit For
            End If
        Next wb
        myFullName = ThisWorkbook.FullName  ' ten day du cua tap tin co code dang duoc thuc thi
        filename = ThisWorkbook.Path & "\nguon.xlsm"    ' ten day du cua tap tin nguon.xlsm
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filename) Then fso.DeleteFile filename, True  ' neu ton tai tap tin ... nguon.xlsm thi xoa
        ThisWorkbook.SaveAs filename    ' ghi tap tin hien hanh voi ten nguon.xlsm
        fso.DeleteFile myFullName   ' xoa tap tin cu sau khi luu voi ten moi la nguon.xlsm
        Set fso = Nothing
    End If
End Sub

Quá chuẩn, cháu không còn ý kiến gì thêm nữa (nhưng cái cháu muốn sub doi_ten chạy tự động khi mở file, không phải là bấm nút)
Cảm ơn chú siêu nhân người dơi rất là nhiều.

Cháu viết lại kết quả mong muốn của cháu bằng hình ảnh,để mọi người hiểu thêm vì cháu thấy mọi người có vẻ vẫn chưa hiểu hết.
Hình ảnh trước khi chạy code:


Kết quả sau khi chạy code:

 

[HieuCD]

Quá chuẩn, cháu không còn ý kiến gì thêm nữa (nhưng cái cháu muốn sub doi_ten chạy tự động khi mở file, không phải là bấm nút)
Cảm ơn chú siêu nhân người dơi rất là nhiều.

Cháu viết lại kết quả mong muốn của cháu bằng hình ảnh,để mọi người hiểu thêm vì cháu thấy mọi người có vẻ vẫn chưa hiểu hết.
Hình ảnh trước khi chạy code:
View attachment 264628

Kết quả sau khi chạy code:

View attachment 264629

Ngay bài đầu mình đã biết ý của bạn rồi, và thấy không hợp lý, phải thực hiện hàng loạt thao tác: Mở file, mở code, copy code, đóng file lưu, mở file. Chỉ cần bấm chuột phải trong folder đổi tên là xong

 

[huuthang_bd]

Qua mô tả và yêu cầu của thớt thì tôi đoán như thế này:
Thực trạng:
Thớt gửi file cho người khác để nhập dữ liệu sau đó gửi lại cho thớt. Thớt có các file khác link tới file này nhưng do trong quá trình gửi qua gửi lại tên file bị thay đổi nên các file có link tới file gốc không cập nhật được dữ liệu.
Yêu cầu:
Khi mở file nhận từ người khác nếu tên không đúng thì sửa lại cho đúng để các file khác cập nhật được dữ liệu.
--

Const sFolderName As String = "MyFolder"
Const sFileName As String = "nguon.xlsm"
Private Sub Workbook_Open()
Dim WB As Workbook, oFSO As Object, sFolderPath As String, sThisFileName As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFolderPath = ThisWorkbook.Path
If LCase(oFSO.GetBaseName(sFolderPath)) = LCase(sFolderName) Then
    If LCase(ThisWorkbook.Name) <> LCase(sFileName) Then
        If (MsgBox("Ten file da bi sua, ban co muon sua lai khong?", vbYesNo) = vbYes) Then
            CloseWB sFileName
            If oFSO.FileExists(sFolderPath & "\" & sFileName) Then
                oFSO.GetFile(sFolderPath & "\" & sFileName).Name = Replace(sFileName, ".xlsm", "_" & Format(Format(Now(), "yymmdd hhmmss")) & ".xlsm")
            End If
            sThisFileName = ThisWorkbook.FullName
            ThisWorkbook.SaveAs sFolderPath & "\" & sFileName
            oFSO.DeleteFile sThisFileName, True
        End If
    End If
End If
End Sub
Private Sub CloseWB(sWBName As String)
    On Error Resume Next
    Workbooks(sWBName).Close True
End Sub

 

[Ngày mai trời lại sáng]

Qua mô tả và yêu cầu của thớt thì tôi đoán như thế này:
Thực trạng:
Thớt gửi file cho người khác để nhập dữ liệu sau đó gửi lại cho thớt. Thớt có các file khác link tới file này nhưng do trong quá trình gửi qua gửi lại tên file bị thay đổi nên các file có link tới file gốc không cập nhật được dữ liệu.
Yêu cầu:
Khi mở file nhận từ người khác nếu tên không đúng thì sửa lại cho đúng để các file khác cập nhật được dữ liệu.
--

Const sFolderName As String = "MyFolder"
Const sFileName As String = "nguon.xlsm"
Private Sub Workbook_Open()
Dim WB As Workbook, oFSO As Object, sFolderPath As String, sThisFileName As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFolderPath = ThisWorkbook.Path
If LCase(oFSO.GetBaseName(sFolderPath)) = LCase(sFolderName) Then
    If LCase(ThisWorkbook.Name) <> LCase(sFileName) Then
        If (MsgBox("Ten file da bi sua, ban co muon sua lai khong?", vbYesNo) = vbYes) Then
            CloseWB sFileName
            If oFSO.FileExists(sFolderPath & "\" & sFileName) Then
                oFSO.GetFile(sFolderPath & "\" & sFileName).Name = Replace(sFileName, ".xlsm", "_" & Format(Format(Now(), "yymmdd hhmmss")) & ".xlsm")
            End If
            sThisFileName = ThisWorkbook.FullName
            ThisWorkbook.SaveAs sFolderPath & "\" & sFileName
            oFSO.DeleteFile sThisFileName, True
        End If
    End If
End If
End Sub
Private Sub CloseWB(sWBName As String)
    On Error Resume Next
    Workbooks(sWBName).Close True
End Sub

Thực trạng và yêu cầu đúng như bác đang hiểu. Code hay quá:
Xử lý thêm trường hợp nằm trong tên thư mục cần xử lý cái này khá quan trong nếu không có cái này thư mục nào code cũng chạy.
Thêm lựa chọn backup lại file nguồn cũ (không xóa), cái này bác có thể xử lý thêm cho em tự tạo thêm thư mục có tên "Backup" nếu nó chưa có thư mục nằm trong thư mục "MyFolder" và di chuyển file nguồn cũ vào thư mục này được không để thư mục "MyFolder" không bị nhiều file, còn nếu có thư mục "Backup" rồi thì di chuyển file nguồn cũ vào thôi (không xóa hoặc tạo mới)
Cảm ơn bác rất nhiều.

 

[Ngày mai trời lại sáng]

Ngay bài đầu mình đã biết ý của bạn rồi, và thấy không hợp lý, phải thực hiện hàng loạt thao tác: Mở file, mở code, copy code, đóng file lưu, mở file. Chỉ cần bấm chuột phải trong folder đổi tên là xong

Em công nhận để xử lý vấn đề này với người đã biết như em (hoặc những người biết nguyên nhân và xử lý được vấn đề) thì không sao có thể làm được nó rất đơn giản, có những file tên tiếng nước ngoài phải copy ra và dán vào, nhưng với người khác như đồng nghiệp mới,sếp nhiều tuổi, hay những người kiến thức cơ bản excel kém thậm trí chưa biết gì.. nên không biết nguyên nhân thao tác này này để sửa nên mới phải làm vậy bác.

 

[huuthang_bd]

Thực trạng và yêu cầu đúng như bác đang hiểu. Code hay quá:
Xử lý thêm trường hợp nằm trong tên thư mục cần xử lý cái này khá quan trong nếu không có cái này thư mục nào code cũng chạy.
Thêm lựa chọn backup lại file nguồn cũ (không xóa), cái này bác có thể xử lý thêm cho em tự tạo thêm thư mục có tên "Backup" nếu nó chưa có thư mục nằm trong thư mục "MyFolder" và di chuyển file nguồn cũ vào thư mục này được không để thư mục "MyFolder" không bị nhiều file, còn nếu có thư mục "Backup" rồi thì di chuyển file nguồn cũ vào thôi (không xóa hoặc tạo mới)
Cảm ơn bác rất nhiều.

Chuyển file vào thư mục Backup theo yêu cầu của bạn.

Const sFolderName As String = "MyFolder"
Const sFileName As String = "nguon.xlsm"
Private Sub Workbook_Open()
Dim WB As Workbook, oFSO As Object, sFolderPath As String, sThisFileName As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFolderPath = ThisWorkbook.Path
If LCase(oFSO.GetBaseName(sFolderPath)) = LCase(sFolderName) Then
    sBackupPath = sFolderPath & "\Backup"
    If LCase(ThisWorkbook.Name) <> LCase(sFileName) Then
        If (MsgBox("Ten file da bi sua, ban co muon sua lai khong?", vbYesNo) = vbYes) Then
            CloseWB sFileName
            If oFSO.FileExists(sFolderPath & "\" & sFileName) Then
                If Not oFSO.FolderExists(sFolderPath & "\Backup") Then
                    oFSO.CreateFolder sFolderPath & "\Backup"
                End If
                oFSO.MoveFile sFolderPath & "\" & sFileName, sFolderPath & "\Backup\" & Replace(sFileName, ".xlsm", "_" & Format(Format(Now(), "yymmdd hhmmss")) & ".xlsm")
            End If
            sThisFileName = ThisWorkbook.FullName
            ThisWorkbook.SaveAs sFolderPath & "\" & sFileName
            oFSO.DeleteFile sThisFileName, True
        End If
    End If
End If
End Sub
Private Sub CloseWB(sWBName As String)
    On Error Resume Next
    Workbooks(sWBName).Close True
End Sub

 

[Ngày mai trời lại sáng]

Chuyển file vào thư mục Backup theo yêu cầu của bạn.

Const sFolderName As String = "MyFolder"
Const sFileName As String = "nguon.xlsm"
Private Sub Workbook_Open()
Dim WB As Workbook, oFSO As Object, sFolderPath As String, sThisFileName As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFolderPath = ThisWorkbook.Path
If LCase(oFSO.GetBaseName(sFolderPath)) = LCase(sFolderName) Then
    sBackupPath = sFolderPath & "\Backup"
    If LCase(ThisWorkbook.Name) <> LCase(sFileName) Then
        If (MsgBox("Ten file da bi sua, ban co muon sua lai khong?", vbYesNo) = vbYes) Then
            CloseWB sFileName
            If oFSO.FileExists(sFolderPath & "\" & sFileName) Then
                If Not oFSO.FolderExists(sFolderPath & "\Backup") Then
                    oFSO.CreateFolder sFolderPath & "\Backup"
                End If
                oFSO.MoveFile sFolderPath & "\" & sFileName, sFolderPath & "\Backup\" & Replace(sFileName, ".xlsm", "_" & Format(Format(Now(), "yymmdd hhmmss")) & ".xlsm")
            End If
            sThisFileName = ThisWorkbook.FullName
            ThisWorkbook.SaveAs sFolderPath & "\" & sFileName
            oFSO.DeleteFile sThisFileName, True
        End If
    End If
End If
End Sub
Private Sub CloseWB(sWBName As String)
    On Error Resume Next
    Workbooks(sWBName).Close True
End Sub

Code rất chuyên nghiệp,em chưa thấy lỗi (vấn đề) xảy ra. À mà em không làm được nên nhờ vả không dám yêu cầu .
Cảm ơn bác nhiều.