Giúp viết code đổi tên sheet của nhiều file trong excel

Liên hệ QC
X

xuan_nam

Thành viên chính thức
Tham gia
30/7/09
Bài viết
51
Được thích
1
Tôi có nhiều file excel, có bác nào giúp viết code để đổi tên sheet"BC Khối phòng học-Khac" thành "phonghoc" tất cả các file không ạ. Xin cảm ơn trước ạ.
 

File đính kèm

  • 3.zip
    161.6 KB · Đọc: 12
xuan_nam đã viết:
Tôi có nhiều file excel, có bác nào giúp viết code để đổi tên sheet"BC Khối phòng học-Khac" thành "phonghoc" tất cả các file không ạ. Xin cảm ơn trước ạ.
Nhấp chuột vào đây để mở rộng...
Tôi có tìm được đoạn code này
Sub ReNameWSheet()
On Error Resume Next
Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k
OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
If TypeName(OpFile) = "Boolean" Then
Exit Sub
Else
For k = 1 To UBound(OpFile)
Set Wb = Application.Workbooks.Open(OpFile(k))
For Each Sh In Wb.Worksheets
Sh.Name = "Phong hoc"
Next
Wb.Save
Wb.Close
Next
End If
End Sub
nhưng nó đổi tên ngay sheet đầu vậy muốn nó đổi tên của sheet thứ 2 thì sửa chỗ nào. Có ai chỉ giúp với ạ
 
Tên sheet bằng tiếng Việt, có thể không hoạt động, nhưng cú pháp chung là như vậy:
Mã: 
For Each Sh In Wb.Worksheets
if  Sh.Name = "BC Khối phòng học-Khac " then Sh.Name = "Phong hoc"
Next
 
phuocam đã viết:
Tên sheet bằng tiếng Việt, có thể không hoạt động, nhưng cú pháp chung là như vậy:
Mã: 
For Each Sh In Wb.Worksheets
if  Sh.Name = "BC Khối phòng học-Khac " then Sh.Name = "Phong hoc"
Next
Nhấp chuột vào đây để mở rộng...
Đúng là không hoạt động. Có cách nào khác không nhỉ
 
xuan_nam đã viết:
Tôi có tìm được đoạn code này
Sub ReNameWSheet()
On Error Resume Next
Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k
OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
If TypeName(OpFile) = "Boolean" Then
Exit Sub
Else
For k = 1 To UBound(OpFile)
Set Wb = Application.Workbooks.Open(OpFile(k))
For Each Sh In Wb.Worksheets
Sh.Name = "Phong hoc"
Next
Wb.Save
Wb.Close
Next
End If
End Sub
nhưng nó đổi tên ngay sheet đầu vậy muốn nó đổi tên của sheet thứ 2 thì sửa chỗ nào. Có ai chỉ giúp với ạ
Nhấp chuột vào đây để mở rộng...
Tôi sửa lại Code của bạn 1 chút:
PHP: 
Sub ReNameWSheet2()
    On Error Resume Next
    Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If TypeName(OpFile) = "Boolean" Then
        Exit Sub
    Else
        For k = 1 To UBound(OpFile)
            Set Wb = Application.Workbooks.Open(OpFile(k))
            For Each Sh In Wb.Worksheets
                If Sh.Name <> "BC Thiet bi" And Sh.Name <> "BCao Nhanh" Then
                    Sh.Name = "phonghoc"
                End If
            Next
            Wb.Save
            Wb.Close
        Next
    End If
End Sub
Bài đã được tự động gộp:

xuan_nam đã viết:
Tôi có tìm được đoạn code này
Sub ReNameWSheet()
On Error Resume Next
Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k
OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
If TypeName(OpFile) = "Boolean" Then
Exit Sub
Else
For k = 1 To UBound(OpFile)
Set Wb = Application.Workbooks.Open(OpFile(k))
For Each Sh In Wb.Worksheets
Sh.Name = "Phong hoc"
Next
Wb.Save
Wb.Close
Next
End If
End Sub
nhưng nó đổi tên ngay sheet đầu vậy muốn nó đổi tên của sheet thứ 2 thì sửa chỗ nào. Có ai chỉ giúp với ạ
Nhấp chuột vào đây để mở rộng...
Hoặc:
PHP: 
Sub ReNameWSheet3()
    On Error Resume Next
    Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k, i
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If TypeName(OpFile) = "Boolean" Then
        Exit Sub
    Else
        For k = 1 To UBound(OpFile)
            Set Wb = Application.Workbooks.Open(OpFile(k))
            Sheets(2).Name = "phonghoc"
            Wb.Save
            Wb.Close
        Next
    End If
End Sub
 
Lần chỉnh sửa cuối:
phulien1902 đã viết:
Tôi sửa lại Code của bạn 1 chút:
PHP: 
Sub ReNameWSheet2()
    On Error Resume Next
    Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If TypeName(OpFile) = "Boolean" Then
        Exit Sub
    Else
        For k = 1 To UBound(OpFile)
            Set Wb = Application.Workbooks.Open(OpFile(k))
            For Each Sh In Wb.Worksheets
                If Sh.Name <> "BC Thiet bi" And Sh.Name <> "BCao Nhanh" Then
                    Sh.Name = "phonghoc"
                End If
            Next
            Wb.Save
            Wb.Close
        Next
    End If
End Sub
Bài đã được tự động gộp:


Hoặc:
PHP: 
Sub ReNameWSheet3()
    On Error Resume Next
    Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k, i
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If TypeName(OpFile) = "Boolean" Then
        Exit Sub
    Else
        For k = 1 To UBound(OpFile)
            Set Wb = Application.Workbooks.Open(OpFile(k))
            Sheets(2).Name = "phonghoc"
            Wb.Save
            Wb.Close
        Next
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Nó vẫn đổi tên sheet đầu tiên không biết là lỗi chỗ nào
 
xuan_nam đã viết:
Nó vẫn đổi tên sheet đầu tiên không biết là lỗi chỗ nào
Nhấp chuột vào đây để mở rộng...
Tôi đã thử ở máy tôi cho kết quả đúng như ý muốn.
Có 1 điều lưu ý với bạn là tên sheet( Tab Sheet) bạn không nên đặt bằng tiếng Việt có dấu. Từ đó việc thay tên Sheet của bạn từ nhiều File sẽ dễ dàng hơn.
 
phulien1902 đã viết:
Tôi đã thử ở máy tôi cho kết quả đúng như ý muốn.
Có 1 điều lưu ý với bạn là tên sheet( Tab Sheet) bạn không nên đặt bằng tiếng Việt có dấu. Từ đó việc thay tên Sheet của bạn từ nhiều File sẽ dễ dàng hơn.
Nhấp chuột vào đây để mở rộng...
Mình vẫn biết thế. Vì đã lỡ rồi nên phải đổi lại không dấu, bạn thông cảm! cảm ơn bạn đã giúp
 
Đặt tên sheet bằng tiếng Việt là lẽ dĩ nhiên.

Để đơn giản hơn bạn sử dụng hàm dưới đây để dễ dàng đổi tên tiếng Việt

- Trả lại một chuỗi mã hóa đơn giản của kiểu gõ Telex
UniMethod("BC Khối phòng học-Khac ", False)

Bật cửa sổ Immediate trong VBE lên (Ctrl+G) và gõ:
?UniMethod(Sheets(2).Name, 0) và Enter

- Trả lại một chuỗi tiếng Việt từ kiểu gõ Telex
UniMethod("BC Kh<oos>i ph<of>ng h<oj>c-Kh<as>c")

Nếu không dùng Hàm bên dưới thì ta dùng cách sau:
Thay các ký tự có dấu thành dấu * và dùng toán tử Like trong VBA:

If LCase$(Sh.Name) Like LCase$("BC Kh*i ph*ng h*c-Khac") Then Sh.Name = "phonghoc"

-------------------------------------
PHP: 
'Lấy Code trên Sửa lại'
Sub ReNameSheet()
    On Error Resume Next
    Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k%
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If Err.Number <> 0 Then Exit Sub
        For k = LBound(OpFile) To UBound(OpFile)
            Set Wb = Application.Workbooks.Open(OpFile(k))
            Set Sh = Wb.Worksheets("phonghoc")
            If Err.Number <> 0 Then
                For Each Sh In Wb.Worksheets
                    'If LCase$(Sh.Name) Like LCase$("BC Kh*i ph*ng h*c-Khac") Then Sh.Name = "phonghoc"'
                    If LCase$(Sh.Name) = LCase$(UniMethod("BC Kh<oos>i ph<of>ng h<oj>c-Khac")) Then
                        Sh.Name = "phonghoc"
                    End If
                Next
            End If
            Wb.Save: Wb.Close
            Err.Clear
        Next
End Sub

Function UniMethod(ByVal Text$, _
      Optional ByVal Decode As Boolean = True) As String
  Dim Telex_Type, CharCode, I&, Ls$, ch$
  Telex_Type = Array("aws", "awf", "awr", "awx", "awj", "aas", "aaf", "aar", "aax", "aaj", "ees", _
      "eef", "eer", "eex", "eej", "oos", "oof", "oor", "oox", "ooj", "ows", "owf", "owr", "owx", _
      "owj", "uws", "uwf", "uwr", "uwx", "uwj", "as", "af", "ar", "ax", "aj", "aw", "aa", "dd", _
      "es", "ef", "er", "ex", "ej", "ee", "is", "if", "ir", "ix", "ij", "os", "of", "or", "ox", _
      "oj", "oo", "ow", "us", "uf", "ur", "ux", "uj", "uw", "ys", "yf", "yr", "yx", "yj")
  CharCode = Array(7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 7871, 7873, 7875, 7877, 7879, _
            7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 7913, 7915, 7917, 7919, 7921, 225, _
            224, 7843, 227, 7841, 259, 226, 273, 233, 232, 7867, 7869, 7865, 234, 237, 236, 7881, 297, 7883, _
            243, 242, 7887, 245, 7885, 244, 417, 250, 249, 7911, 361, 7909, 432, 253, 7923, 7927, 7929, 7925)
  For I = LBound(CharCode) To UBound(CharCode)
    ch = ChrW(CharCode(I)): Ls = "<" & Telex_Type(I) & ">"
    Text = Replace$(Text, IIf(Decode, Ls, ch), IIf(Decode, ch, Ls))
    Text = Replace$(Text, IIf(Decode, UCase$(Ls), UCase$(ch)), IIf(Decode, UCase$(ch), UCase$(Ls)))
    DoEvents
  Next I
  UniMethod = Text
End Function
 
Lần chỉnh sửa cuối:
xuan_nam đã viết:
Mình vẫn biết thế. Vì đã lỡ rồi nên phải đổi lại không dấu, bạn thông cảm! cảm ơn bạn đã giúp
Nhấp chuột vào đây để mở rộng...
đổi lại không dấu thủ công hả bạn? thế thì đổi luôn tên sheet luôn còn gì? bạn code theo #10 là được.
 
xuan_nam đã viết:
Đúng là đổi tên sheet đó bạn, làm theo #10 thì vẫn còn chữ "phòng" vba nó cũng không hoạt động
Nhấp chuột vào đây để mở rộng...
Code này mà không được à bạn?
Mã: 
Sub DoiTen()
    On Error Resume Next
    Dim OpFile As Variant, Wb As Workbook, iFile As Variant
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If TypeName(OpFile) = "Boolean" Then
        Exit Sub
    Else
        For Each iFile In OpFile
            Set Wb = Application.Workbooks.Open(iFile)
            Wb.Sheets("BC Kh" & ChrW(7889) & "i ph" & ChrW(242) & "ng h" & ChrW(7885) & "c-Khac").Name = "phonghoc"
            Wb.Close True
        Next
    End If
End Sub
 
huuthang_bd đã viết:
Code này mà không được à bạn?
Mã: 
Sub DoiTen()
    On Error Resume Next
    Dim OpFile As Variant, Wb As Workbook, iFile As Variant
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If TypeName(OpFile) = "Boolean" Then
        Exit Sub
    Else
        For Each iFile In OpFile
            Set Wb = Application.Workbooks.Open(iFile)
            Wb.Sheets("BC Kh" & ChrW(7889) & "i ph" & ChrW(242) & "ng h" & ChrW(7885) & "c-Khac").Name = "phonghoc"
            Wb.Close True
        Next
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Code này thì tốt rồi.
Tôi có file đính kèm, Muốn copy dữ liệu từ các file paste Transport sang file tổng hợp, tôi có code nhưng nó paste theo hàng dọc, ban có thẻ sửa code này cho nó dán theo hàng ngang được không, xin chân thành cảm ơn.
 

File đính kèm

  • Tong hop.zip
    289.4 KB · Đọc: 5
HeSanbi đã viết:
Đặt tên sheet bằng tiếng Việt là lẽ dĩ nhiên.

Để đơn giản hơn bạn sử dụng hàm dưới đây để dễ dàng đổi tên tiếng Việt

- Trả lại một chuỗi mã hóa đơn giản của kiểu gõ Telex
UniMethod("BC Khối phòng học-Khac ", False)

Bật cửa sổ Immediate trong VBE lên (Ctrl+G) và gõ:
?UniMethod(Sheets(2).Name, 0) và Enter

- Trả lại một chuỗi tiếng Việt từ kiểu gõ Telex
UniMethod("BC Kh<oos>i ph<of>ng h<oj>c-Kh<as>c")

Nếu không dùng Hàm bên dưới thì ta dùng cách sau:
Thay các ký tự có dấu thành dấu * và dùng toán tử Like trong VBA:

If LCase$(Sh.Name) Like LCase$("BC Kh*i ph*ng h*c-Khac") Then Sh.Name = "phonghoc"

-------------------------------------
PHP: 
'Lấy Code trên Sửa lại'
Sub ReNameSheet()
    On Error Resume Next
    Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k%
    OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
    If Err.Number <> 0 Then Exit Sub
        For k = LBound(OpFile) To UBound(OpFile)
            Set Wb = Application.Workbooks.Open(OpFile(k))
            Set Sh = Wb.Worksheets("phonghoc")
            If Err.Number <> 0 Then
                For Each Sh In Wb.Worksheets
                    'If LCase$(Sh.Name) Like LCase$("BC Kh*i ph*ng h*c-Khac") Then Sh.Name = "phonghoc"'
                    If LCase$(Sh.Name) = LCase$(UniMethod("BC Kh<oos>i ph<of>ng h<oj>c-Khac")) Then
                        Sh.Name = "phonghoc"
                    End If
                Next
            End If
            Wb.Save: Wb.Close
            Err.Clear
        Next
End Sub

Function UniMethod(ByVal Text$, _
      Optional ByVal Decode As Boolean = True) As String
  Dim Telex_Type, CharCode, I&, Ls$, ch$
  Telex_Type = Array("aws", "awf", "awr", "awx", "awj", "aas", "aaf", "aar", "aax", "aaj", "ees", _
      "eef", "eer", "eex", "eej", "oos", "oof", "oor", "oox", "ooj", "ows", "owf", "owr", "owx", _
      "owj", "uws", "uwf", "uwr", "uwx", "uwj", "as", "af", "ar", "ax", "aj", "aw", "aa", "dd", _
      "es", "ef", "er", "ex", "ej", "ee", "is", "if", "ir", "ix", "ij", "os", "of", "or", "ox", _
      "oj", "oo", "ow", "us", "uf", "ur", "ux", "uj", "uw", "ys", "yf", "yr", "yx", "yj")
  CharCode = Array(7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 7871, 7873, 7875, 7877, 7879, _
            7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 7913, 7915, 7917, 7919, 7921, 225, _
            224, 7843, 227, 7841, 259, 226, 273, 233, 232, 7867, 7869, 7865, 234, 237, 236, 7881, 297, 7883, _
            243, 242, 7887, 245, 7885, 244, 417, 250, 249, 7911, 361, 7909, 432, 253, 7923, 7927, 7929, 7925)
  For I = LBound(CharCode) To UBound(CharCode)
    ch = ChrW(CharCode(I)): Ls = "<" & Telex_Type(I) & ">"
    Text = Replace$(Text, IIf(Decode, Ls, ch), IIf(Decode, ch, Ls))
    Text = Replace$(Text, IIf(Decode, UCase$(Ls), UCase$(ch)), IIf(Decode, UCase$(ch), UCase$(Ls)))
    DoEvents
  Next I
  UniMethod = Text
End Function
Nhấp chuột vào đây để mở rộng...
Tôi có file đính kèm, Muốn copy dữ liệu từ các file paste Transport sang file tổng hợp, tôi có code nhưng nó paste theo hàng dọc, ban có thể sửa code này cho nó dán theo hàng ngang được không, xin chân thành cảm ơn
 

File đính kèm

  • Tong hop.zip
    289.4 KB · Đọc: 5
xuan_nam đã viết:
Code này thì tốt rồi.
Tôi có file đính kèm, Muốn copy dữ liệu từ các file paste Transport sang file tổng hợp, tôi có code nhưng nó paste theo hàng dọc, ban có thẻ sửa code này cho nó dán theo hàng ngang được không, xin chân thành cảm ơn.
Nhấp chuột vào đây để mở rộng...
Bạn lập 1 bài viết mới nhé.
 
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

A
[Góc giúp đỡ] Tìm kiếm, lọc và lấy dữ liệu từ nhiều file Word cấu trúc giống nhau vào 1 file excel mẫu
Trả lời
2
Đọc
44
anhgp1
A
T
  • Question
Ghép 2 cột dữ liệu
Trả lời
2
Đọc
13
HieuCD
H
T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
11
Đọc
159
VetMini
V
N
Xin code tính tổng số cấu đúng viết trong "Visual Basic" trong PPT
Trả lời
1
Đọc
4K
hahuy_hien2000
H
8
Hàm thống kê số lượng thành viên câu lạc bộ theo từng đợt tuyển thành viên
Trả lời
3
Đọc
88
HieuCD
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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