Giúp đổi tên nhiều sheet nhiều file excel

Liên hệ QC
R

rname

Thành viên mới
Tham gia
10/7/14
Bài viết
6
Được thích
0
Chào các bạn. Mình có nhiều file xls, mỗi file có nhiều sheet. Giờ cần đổi tên tất cả các sheet của tất cả các file ví dụ: file 1 có 100 sheet (tên linh tinh hết) giờ phải đổi tên theo thứ tự sheet 1 thành kh01, sheet 2 thành kh02,...đến sheet 100 hoặc thứ tự người lại sheet 100 thành kh01, sheet 99 thành kh02...đến sheet1 các file khác đổi tên như file 1. mong các bạn giúp đỡ. Cảm ơn.,

Có thể chọn đổi tên sheet theo thứ tự trai sang phải hay phải sang trái được không? dùng code như thế nào? vd: có 3 sheet từ trái sang phải tên là sheet1,sheet2,sheet3 giờ đổi từ trái sang phải thành kh01,kh02,kh03 còn đổi từ phải sang trái là kh03,kh02,kh01 tks.

tên sheet từ thứ tự 10 trở lên nó sẽ thành kh010,011...thay vì kh10,11. Mong bạn giúp luôn chỗ này.
 
Lần chỉnh sửa cuối:
Làm đoạn code này chạy chơi vậy bạn!!!
PHP: 
Sub DoitenSh()
Dim Sh As Worksheet
For Each Sh In ActiveWorkbook.Worksheets
    Sh.Name = "KH" & Format(Sh.Index, "000")
Next
End Sub
 
vu_tuan_manh_linh đã viết:
Làm đoạn code này chạy chơi vậy bạn!!!
PHP: 
 Sub DoitenSh() Dim Sh As Worksheet For Each Sh In ActiveWorkbook.Worksheets     Sh.Name = "KH" & Format(Sh.Index, "000") Next End Sub
Nhấp chuột vào đây để mở rộng...
Có thể chọn đổi tên sheet theo thứ tự trai sang phải hay phải sang trái được không? dùng code như thế nào? vd: có 3 sheet từ trái sang phải tên là sheet1,sheet2,sheet3 giờ đổi từ trái sang phải thành kh01,kh02,kh03 còn đổi từ phải sang trái là kh03,kh02,kh01 tks.
 
rname đã viết:
Có thể chọn đổi tên sheet theo thứ tự trai sang phải hay phải sang trái được không? dùng code như thế nào? vd: có 3 sheet từ trái sang phải tên là sheet1,sheet2,sheet3 giờ đổi từ trái sang phải thành kh01,kh02,kh03 còn đổi từ phải sang trái là kh03,kh02,kh01 tks.
Nhấp chuột vào đây để mở rộng...

Hoàn toàn được chứ sao không, có thể Sort theo thứ tự từ nhỏ đến lớn hoặc từ lớn đến nhỏ. Bạn thử sử dụng code trong Module.

PHP: 
Sub Sort_ThuTu()
Dim i As Integer
Dim j As Integer
Dim a As Integer, b As Integer, Sn1 As String, Sn2 As String
Dim iAnswer As VbMsgBoxResult
Dim c As String

iAnswer = MsgBox("Click Yes SAP XEP SHEET THEO THU TU TANG DAN?" & Chr(10)_
       & "Click No SAP XEP SHEET THEO THU TU GIAM DAN", _
       vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")   

  For i = 1 To Sheets.Count      
  For j = 1 To Sheets.Count - 1
     If iAnswer = vbYes Then            
        Sn1 = "": Sn2 = ""            
        For a = 1 To Len(Sheets(j).Name)            
     If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then            
        Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)            
        End If            
        Next a
           
  For b = 1 To Len(Sheets(j + 1).Name)            
     If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then            
        Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)            
        End If            
        Next b
     If a <> 0 Then            
     If Val(Sn1) > Val(Sn2) Then               
        Sheets(j).Move After:=Sheets(j + 1)            
     End If            
     Else            
     If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then               
        Sheets(j).Move After:=Sheets(j + 1)            
     End If            
     End If
     ElseIf iAnswer = vbNo Then                        
        Sn1 = "": Sn2 = ""           
  For a = 1 To Len(Sheets(j).Name)            
     If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then            
     Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)            
     End If            
     Next a
  For b = 1 To Len(Sheets(j + 1).Name)            
     If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then            
     Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)            
     End If            
     Next b
     If a <> 0 Then            
     If Val(Sn1) < Val(Sn2) Then               
        Sheets(j).Move After:=Sheets(j + 1)            
     End If            
     Else            
     If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then               
        Sheets(j).Move After:=Sheets(j + 1)            
     End If                           
     End If      
     Next j   
     Next i
End Sub
 
Lần chỉnh sửa cuối:
Sáng đọc bài chập chờn câu cú nên trả lời không chính xác, nên xin lỗi các bạn, mong các bạn thông cãm.

Lỡ viết bài rồi rồi nên tôi để luôn để các bạn có thể sử dụng vào việc sort sheet theo thứ tự tăng dần hoặc giảm dần.
 
Lần chỉnh sửa cuối:
Để bạn tham khảo cho vui

PHP: 
Option Explicit
Sub DoitenSh()
Dim Sh As Worksheet, Ch As String, KT As String
Dim J As Long, Max_ As Byte, Min_ As Byte, Num As Byte, Mu As Byte, Tmp As Byte
Num = Worksheets.Count
Ch = InputBox("Tang Hay Giam", "Dè Nghi Hay Chon Huóng", "T")
If UCase(Left(Ch, 1)) = "T" Then
    Min_ = 1:               Mu = 2
    Max_ = Num:             KT = "000"
Else
    Min_ = Num:             Mu = 3
    Max_ = 1:               KT = "_0"
End If
For J = Min_ To Max_ Step (-1) ^ Mu
    Tmp = Tmp + 1
    Sheets(J).Name = "KH" & Right(KT & CStr(Tmp), Mu + 1)
Next J
End Sub
 
cảm ơn các bạn
code HYen17 chạy được nhưng có 1 chút phát sinh nhỏ là với tên sheet từ thứ tự 10 trở lên nó sẽ thành kh010,011...thay vì kh10,11. Mong bạn giúp luôn chỗ này.
Code be09 thì báo lỗi syntax gì đó, mình không rành nên chịu thua.
 
rname đã viết:
Chào các bạn. Mình có nhiều file xls, mỗi file có nhiều sheet. Giờ cần đổi tên tất cả các sheet của tất cả các file ví dụ: file 1 có 100 sheet (tên linh tinh hết) giờ phải đổi tên theo thứ tự sheet 1 thành kh01, sheet 2 thành kh02,...đến sheet 100 hoặc thứ tự người lại sheet 100 thành kh01, sheet 99 thành kh02...đến sheet1 các file khác đổi tên như file 1. mong các bạn giúp đỡ. Cảm ơn.,
Nhấp chuột vào đây để mở rộng...
Thử code này
PHP: 
Sub ReNameSheet()
Dim WS As Worksheet, Order, i, Temp, Newsh
Order = MsgBox("From Right To Left?", vbYesNo)
With CreateObject("System.Collections.ArrayList")
   For Each WS In ThisWorkbook.Worksheets
      .Add WS.Name
   Next
   .Sort
   If Order = vbYes Then .Reverse
   Temp = .ToArray
   For i = 0 To UBound(Temp)
      Newsh = Right("000" & i + 1, Len(i) + 1)
      Sheets(Temp(i)).Name = "KH" & Newsh
   Next
End With
End Sub
 
Mình đọc các bài và có 1 thắc mắc:Chủ topic nêu là có rất nhiều file cần đổi tên WorkSheet nhưng các bài trả lời chỉ có 1 file nhung chả ai có ý kiến, kể cả chủ Topic

Mình thấy Code như sau mới có thể chứ:
Mã: 
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 = "Kh" & Format(Sh.Index, "000")
Next
Wb.Save
Wb.Close
Next
End If
End Sub
 
Lúc chạy báo lỗi activex [r dòng mình tô đỏ dòng này With CreateObject("System.Collections.ArrayList")
quanghai1969 đã viết:
Thử code này
PHP: 
 Sub ReNameSheet() Dim WS As Worksheet, Order, i, Temp, Newsh Order = MsgBox("From Right To Left?", vbYesNo) With CreateObject("System.Collections.ArrayList")    For Each WS In ThisWorkbook.Worksheets       .Add WS.Name    Next    .Sort    If Order = vbYes Then .Reverse    Temp = .ToArray    For i = 0 To UBound(Temp)       Newsh = Right("000" & i + 1, Len(i) + 1)       Sheets(Temp(i)).Name = "KH" & Newsh    Next End With End Sub
Nhấp chuột vào đây để mở rộng...
@seland: code bạn chạy tốt nhưng có 1 chút phát sinh nhỏ là với tên sheet từ thứ tự 10 trở lên nó sẽ thành kh010,011...thay vì kh10,11. Mong bạn giúp luôn chỗ này.
 
Lần chỉnh sửa cuối:
rname đã viết:
Lúc chạy báo lỗi activex [r dòng mình tô đỏ dòng này With CreateObject("System.Collections.ArrayList) .
Nhấp chuột vào đây để mở rộng...

Thử lại code này
PHP: 
Sub ReNameSheet()
Dim i As Long, NewSh As String, j, k
j = Sheets.Count
If MsgBox("From Right To Left", vbYesNo) = vbNo Then
   For i = 1 To j
      NewSh = Right("000" & i, Len(CStr(j -1)) + 1)
      Sheets(i).Name = "KH" & NewSh
   Next
Else
   For i = j To 1 Step -1
      k = k + 1
      NewSh = Right("000" & k, Len(CStr(k-1)) + 1)
      Sheets(i).Name = "KH" & NewSh
   Next
End If
End Sub
 
Lần chỉnh sửa cuối:
@seland: code bạn chạy tốt nhưng có 1 chút phát sinh nhỏ là với tên sheet từ thứ tự 10 trở lên nó sẽ thành kh010,011...thay vì kh10,11. Mong bạn giúp luôn chỗ này.
Nhấp chuột vào đây để mở rộng...

Vì đang thắc mắc sợ mất công nên chưa viết đầy đủ, còn đầy đủ phải thế này:

Mã: 
Sub ReNameWSheet()
Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k, ByInd
On Error Resume Next
OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
If TypeName(OpFile) = "Boolean" Then
Exit Sub
Else
ByInd = MsgBox("Rename Worksheet by Index ?", vbYesNo)
For k = 1 To UBound(OpFile)
Set Wb = Application.Workbooks.Open(OpFile(k))
For Each Sh In Wb.Worksheets
If ByInd = 6 Then
Wb.Worksheets("Khang" & Format(Sh.Index, "#00")).Name = _
"Kh" & Format(Sh.Index, "#00") & "_TmpSh"
Sh.Name = "Kh" & Format(Sh.Index, "#00")
Else
Wb.Worksheets("Kh" & Format(Wb.Worksheets.Count - Sh.Index + 1, "#00")).Name = _
"Kh" & Format(Wb.Worksheets.Count - Sh.Index + 1, "#00") & "_TmpSh"
 Sh.Name = "Kh" & Format(Wb.Worksheets.Count - Sh.Index + 1, "#00")
 End If
Next
Wb.Save
Wb.Close
Next
Set Sh = Nothing: Set Wb = Nothing
End If
End Sub
 
báo lỗi dòng này
Sheets(i).Name = "KH" & NewSh

như hình đính kèm bạn ơi.

quanghai1969 đã viết:
Thử lại code này
PHP: 
Sub ReNameSheet()
Dim i As Long, NewSh As String, j, k
j = Sheets.Count
If MsgBox("From Right To Left", vbYesNo) = vbNo Then
   For i = 1 To j
      NewSh = Right("000" & i, Len(CStr(j -1)) + 1)
      Sheets(i).Name = "KH" & NewSh
   Next
Else
   For i = j To 1 Step -1
      k = k + 1
      NewSh = Right("000" & k, Len(CStr(k-1)) + 1)
      Sheets(i).Name = "KH" & NewSh
   Next
End If
End Sub
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

  • untitled.JPG
    untitled.JPG
    15.9 KB · Đọc: 41
rname đã viết:
báo lỗi dòng này
Sheets(i).Name = "KH" & NewSh

như hình đính kèm bạn ơi.
Nhấp chuột vào đây để mở rộng...
Do bạn có tên sheet trước đó rồi.
PHP: 
Sub ReNameSheet()
Dim i, NewSh, sh, j, k
j = Sheets.Count
For Each sh In Worksheets
   sh.Name = sh.CodeName
Next
If MsgBox("From Right To Left", vbYesNo) = vbNo Then
   For i = 1 To j
      NewSh = Right("000" & i, 2)
      Sheets(i).Name = "KH" & NewSh
   Next
Else
   For i = j To 1 Step -1
      k = k + 1
      NewSh = Right("000" & k, 2)
      Sheets(i).Name = "KH" & NewSh
   Next
End If
End Sub
 
Lần chỉnh sửa cuối:
sealand đã viết:
Vì đang thắc mắc sợ mất công nên chưa viết đầy đủ, còn đầy đủ phải thế này:

Mã: 
Sub ReNameWSheet()
Dim OpFile As Variant, Sh As Worksheet, Wb As Workbook, k, ByInd
On Error Resume Next
OpFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls", MultiSelect:=True)
If TypeName(OpFile) = "Boolean" Then
Exit Sub
Else
ByInd = MsgBox("Rename Worksheet by Index ?", vbYesNo)
For k = 1 To UBound(OpFile)
Set Wb = Application.Workbooks.Open(OpFile(k))
For Each Sh In Wb.Worksheets
If ByInd = 6 Then
Wb.Worksheets("Khang" & Format(Sh.Index, "#00")).Name = _
"Kh" & Format(Sh.Index, "#00") & "_TmpSh"
Sh.Name = "Kh" & Format(Sh.Index, "#00")
Else
Wb.Worksheets("Kh" & Format(Wb.Worksheets.Count - Sh.Index + 1, "#00")).Name = _
"Kh" & Format(Wb.Worksheets.Count - Sh.Index + 1, "#00") & "_TmpSh"
 Sh.Name = "Kh" & Format(Wb.Worksheets.Count - Sh.Index + 1, "#00")
 End If
Next
Wb.Save
Wb.Close
Next
Set Sh = Nothing: Set Wb = Nothing
End If
End Sub
Nhấp chuột vào đây để mở rộng...

code chạy tốt mà có thể cho chọn đổi theo kiểu trái sang phải hoặc phải sang trái không bạn?
 
code chạy tốt mà có thể cho chọn đổi theo kiểu trái sang phải hoặc phải sang trái không bạn?
Nhấp chuột vào đây để mở rộng...

Đúng vậy, nếu bạn đồng ý thì nó đổi tên sheet theo Index . Nếu chọn No nó sẽ đổi tên ngược lại.
 
Viết theo kiểu bài 14 thì ép luôn không cho cãi. Muốn bị trùng tên cũng không trùng được
 
HYen17 đã viết:
PHP: 
Option Explicit
Sub DoitenSh()
Dim Sh As Worksheet, Ch As String, KT As String
Dim J As Long, Max_ As Byte, Min_ As Byte, Num As Byte, Mu As Byte, Tmp As Byte
Num = Worksheets.Count
Ch = InputBox("Tang Hay Giam", "Dè Nghi Hay Chon Huóng", "T")
If UCase(Left(Ch, 1)) = "T" Then
    Min_ = 1:               Mu = 2
    Max_ = Num:             KT = "000"
Else
    Min_ = Num:             Mu = 3
    Max_ = 1:               KT = "_0"
End If
For J = Min_ To Max_ Step (-1) ^ Mu
    Tmp = Tmp + 1
    Sheets(J).Name = "KH" & Right(KT & CStr(Tmp), Mu + 1)
Next J
End Sub
Nhấp chuột vào đây để mở rộng...

Bạn ơi, mình muốn đổi trên sheet từ 501 đến 600 (50 sheet) thì như thế nào được?? giúp mình với
 
Mọi Người cho em hỏi them chút ạ . em muốn đặt ten sheet theo 1 bang danh sách thì làm thế nào ạ
VD: Ở sheet 1 :ta có B2 :B10 là Buoc1: Buoc8 . Chạy lệnh là nó tạo ra 8 sheet tên từ trái qua phải là Buoc1 tới buoc 8
Em cảm ơn .
 
Hung Luong đã viết:
Mọi Người cho em hỏi them chút ạ . em muốn đặt ten sheet theo 1 bang danh sách thì làm thế nào ạ
VD: Ở sheet 1 :ta có B2 :B10 là Buoc1: Buoc8 . Chạy lệnh là nó tạo ra 8 sheet tên từ trái qua phải là Buoc1 tới buoc 8
Em cảm ơn .
Nhấp chuột vào đây để mở rộng...
Được chứ! Tham khảo code sau:
Mã: 
Private Function SheetExists(ByVal SheetName As String) As Boolean
  On Error Resume Next
  SheetExists = Not Sheets(SheetName) Is Nothing
End Function
Private Function isValidSheetName(ByVal SheetName As String) As Boolean
  If (Len(SheetName) > 31) Or (Len(SheetName) = 0) Then Exit Function
  With CreateObject("VBScript.RegExp")
    .Pattern = "[\\:\][/?*]"
    isValidSheetName = Not .Test(SheetName)
  End With
End Function
Private Sub CreateSheet(ByVal arrSheets As Variant)
  Dim tmpArr, Item
  On Error GoTo ErrHandler
  tmpArr = arrSheets
  If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
  For Each Item In tmpArr
    If isValidSheetName(CStr(Item)) Then
      If Not (SheetExists(CStr(Item))) Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = CStr(Item)
      End If
    End If
  Next
  Exit Sub
ErrHandler: MsgBox Err.Description
End Sub
Sub Main()
  Dim wks As Worksheet
  Set wks = ActiveSheet
  CreateSheet wks.Range("B2:B10")
  wks.Activate
End Sub
Toàn bộ code trên bạn cho vào 1 module và chỉ cần chú ý Sub cuối cùng này:

Sub Main()
Dim wks As Worksheet
Set wks = ActiveSheet
CreateSheet wks.Range("B2:B10")
wks.Activate
End Sub
Nhấp chuột vào đây để mở rộng...
Chỗ màu đỏ là vùng dữ liệu nơi bạn đặt danh sách các sheets. Nếu danh sách nằm chỗ khác, cứ sửa chỗ màu đỏ cho phù hợp là được
 
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

emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
8
Đọc
158
DeTong
D
B
  • Question
Chuyển đổi dữ liệu sạng dạng mảng
Trả lời
7
Đọc
147
Bích Tỷ
B
A
Tính tổng dữ liệu băng dictionary
Trả lời
5
Đọc
65
acca_hcm
A
T
Nhờ giúp tính tổng ô đã Merge
Trả lời
2
Đọc
53
thuytrangbp28
T
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
64
Đọc
965
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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