Khong cho doi ten sheet trong excel 2024

AC cho em hỏi có cách nào khoá tên Sheet không cho thay đổi tên? Giả sử em có Sheet tên DATA và em muốn không cho ai sửa tên nó. AC chỉ dùm em cách nào khoá hữu hiệu nhất!?

Trước khi chạy chú cho cái này

Sheet1.Name = “MENU”
Sheet2.Name = “CSDL”
Sheet3.Name =
“MAIN”
Sheet4.Name = “DN”
Sheet5.Name = “TK”
Sheet6.Name = “SCAI”
Sheet7.Name = “NKC”
Sheet8.Name = “FOOTER”
Sheet9.Name = “SCT”
Sheet10.Name = “KH”
Sheet11.Name = “CDPS”
Sheet12.Name = “KQKD”
Sheet14.Name = “CDKT”

lên đầu thủ tục (theo file chú đã gửi anh)
đảm bảo không cần bẫy lỗi cái này nữa.

Mã:

Option Explicit
Sub TenSheet()
    Sheet1.Name = "MENU"
    Sheet2.Name = "CSDL"
    Sheet3.Name = "MAIN"
    Sheet4.Name = "DN"
    Sheet5.Name = "TK"
    Sheet6.Name = "SCAI"
    Sheet7.Name = "NKC"
    Sheet8.Name = "FOOTER"
    Sheet9.Name = "SCT"
    Sheet10.Name = "KH"
    Sheet11.Name = "CDPS"
    Sheet12.Name = "KQKD"
    Sheet14.Name = "CDKT"
End Sub

Sub Taoso_cdps()
TenSheet
On Error Resume Next
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim rng As Range
Dim eRw1 As Long, eRw2 As Long
Set S1 = Sheets("TK")
Set S2 = Sheets("CDPS")
Application.ScreenUpdating = False
S2.Range("A9:H65535").Clear
eRw1 = S1.Cells(Cells.Rows.Count, "A").End(xlUp).Row
S1.Range("A6:D" & eRw1).Copy Destination:=S2.Range("A9")
eRw2 = S2.Cells(Cells.Rows.Count, "A").End(xlUp).Row
    Range("E9").Formula = "=SUMIF(CSDL!$F$2:$F$65535,CDPS!A9&""*"",CSDL!$H$2:$H$65535)"
    Range("F9").Formula = "=SUMIF(CSDL!$G$2:$G$65535,CDPS!A9&""*"",CSDL!$I$2:$I$65535)"
    Range("G9").Formula = "=MAX(C9+E9-D9-F9,0)"
    Range("H9").Formula = "=MAX(D9+F9-C9-E9,0)"
    'Range("I9").Formula = "=IF(SUM(C9:H9)<>0,1,0)"
    Set rng = S2.Range("E9:H" & eRw2)
    Range("E9:H9").Copy rng
    rng.Value = rng.Value
    rng.NumberFormat = "_(* #,##0_);_(* (#,##0);"""""
    With S2.Range("A9").Resize(eRw2 - 8, 8)
        .BorderAround LineStyle:=1
        .Borders(11).LineStyle = 1: .Borders(11).ColorIndex = 1
        .Borders(12).LineStyle = 1: .Borders(12).ColorIndex = 1
    End With
    Sheets("Footer").Range("A21:H25").Copy S2.Range("A9").Offset(eRw2 - 8)
    With S2.Cells(eRw2 + 1, "C").Resize(, 6)
            .FormulaR1C1 = "=SUBTOTAL(9,R9C:R[-1]C)"
            .Font.Name = "Arial"
            .Font.Size = 11
    End With
    S2.Cells(eRw2 + 1, "C").Resize(, 6).Value = S2.Cells(eRw2 + 1, "C").Resize(, 6).Value
    Set rng = Nothing
    Set S2 = Nothing
    Set S1 = Nothing
End Sub

AC cho em hỏi có cách nào khoá tên Sheet không cho thay đổi tên? Giả sử em có Sheet tên DATA và em muốn không cho ai sửa tên nó. AC chỉ dùm em cách nào khoá hữu hiệu nhất!?

Bạn chọn ToolsProtectProtect Workbook => Nhập 2 lần Password => OK.
Còn nếu muốn dùng code thì
bạn nháy chuột phải tại tên sheet DATA, chọn View code và dán code sau vào:

PHP:

• #5

Cách thứ nhất của anh thì được. Nhưng còn
Code thì em test vẫn chưa được. Em sửa code đó thành:

PHP:

Private Sub Worksheet_Activate()
    Me.Name = "DATA"
End Sub

thì khi Sheet đó được kích hoạt nó lại trả lại tên cũ. Cho em hỏi còn cách viết code nào khác để khoá nữa không ah?

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private ShArr As Object

Sub TimerProc()
  Dim Sh As Worksheet
  On Error Resume Next
  For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> ShArr.Item(Sh.CodeName) Then Sh.Name = ShArr.Item(Sh.CodeName)
  Next
End Sub

Sub Auto_Open()
  Dim Sh As Worksheet
  KillTimer Application.hwnd, 1
  Set ShArr = CreateObject("Scripting.Dictionary")
  For Each Sh In ThisWorkbook.Worksheets
    ShArr.Add Sh.CodeName, Sh.Name
  Next
  SetTimer Application.hwnd, 1, 200, AddressOf TimerProc
End Sub

Sub Auto_Close()
  KillTimer Application.hwnd, 1
End Sub

Sub TimerProc()
  Dim Sh As Worksheet
  On Error Resume Next
  For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> ShArr.Item(Sh.CodeName) Then Sh.Name = ShArr.Item(Sh.CodeName)
  Next
End Sub

Sub Auto_Open()
  Dim Sh As Worksheet
  KillTimer Application.hwnd, 1
  Set ShArr = CreateObject("Scripting.Dictionary")
  For Each Sh In ThisWorkbook.Worksheets
    ShArr.Add Sh.CodeName, Sh.Name
  Next
  SetTimer Application.hwnd, 1, 200, AddressOf TimerProc
End Sub

Sub Auto_Close()
  KillTimer Application.hwnd, 1
End Sub