Tôi có tìm được đoạn code nàyTô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 ạ.
Đúng là không hoạt động. Có cách nào khác không nhỉ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
Có thể đưa tên file tiếng Việt vô code nó không chạy, vậy thì bạn ghi tên tiếng Việt ấy vô 1 cell và tham chiếu tới nó thì code chạy đượcĐúng là không hoạt động. Có cách nào khác không nhỉ
Tôi sửa lại Code của bạn 1 chú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 ạ
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
Hoặc: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 ạ
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
Nó vẫn đổi tên sheet đầu tiên không biết là lỗi chỗ nàoTô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
Tôi đã thử ở máy tôi cho kết quả đúng như ý muốn.Nó vẫn đổi tên sheet đầu tiên không biết là lỗi chỗ nào
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úpTô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.
thử đổiFor Each Sh In Wb.Worksheets if Sh.Name = "BC Khối phòng học-Khac " then Sh.Name = "Phong hoc" Next
'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
đổ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.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
Đú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đổ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.
"BC Kh" & ChrW(7889) & "i ph" & chrw(242) & "ng h" & ChrW(7885) & "c-Khac "Đú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
Code này mà không được à bạn?Đú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
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
Code này thì tốt rồi.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
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Đặ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
Bạn lập 1 bài viết mới nhé.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.
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2