Lỗi tách sheets khi lập trình VBA " That name is already taken.try a different one" (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
hungmanh.th1

hungmanh.th1

Thành viên mới
Tham gia
22/10/22
Bài viết
17
Được thích
0
Chào mọi người ! Mình có một sheets excle cần tách ra thành nhiều sheets nhưng gặp lỗi "that name is already taken. try a different one"
Chỉ tạo ra 1 sheet đầu tiên và báo lỗi như vậy . Nhờ anh em xem code và chỉ giáo ạ !
1667696943152.png
1667696957337.png

Public Sub GPE()
Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each Ws In Worksheets
If Ws.Name <> "ABC1" Then Ws.Delete
Next Ws
Set Wb = ActiveWorkbook
With Wb.Sheets("ABC1")
Set Rng = .Range(.[A11], .[K65000].End(3))
Set Dic = CreateObject("Scripting.Dictionary")
Arr = .Range(.[K12], [K65000].End(3)).Value
For I = 1 To UBound(Arr)
Tem = Arr(I, 1)
If Tem <> Empty And Not Dic.exists(Tem) Then
Item = Tem
Rng.AutoFilter 11, Item
.Range(.[A1], Rng).SpecialCells(12).Copy
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Item
Sheets(Item).[A1].PasteSpecial xlPasteValues
Sheets(Item).[A1].PasteSpecial xlPasteFormats
End If
Next I
.Activate
.AutoFilterMode = False
End With
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
giaiphap đã viết:
Tốt nhất là bạn nên upload file lên để tiện test thử code.
Nhấp chuột vào đây để mở rộng...
Bca s bạn hỗ trợ mình với
Bài đã được tự động gộp:

VetMini đã viết:
Xem rồi. Chỉ nè:

$$$$@View attachment 283029
. .
Nhấp chuột vào đây để mở rộng...
Đại ca chỉ giáo dùm :(
Bài đã được tự động gộp:

hungmanh.th1 đã viết:
Chào mọi người ! Mình có một sheets excle cần tách ra thành nhiều sheets nhưng gặp lỗi "that name is already taken. try a different one"
Chỉ tạo ra 1 sheet đầu tiên và báo lỗi như vậy . Nhờ anh em xem code và chỉ giáo ạ !
View attachment 283026
View attachment 283027

Public Sub GPE()
Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each Ws In Worksheets
If Ws.Name <> "ABC1" Then Ws.Delete
Next Ws
Set Wb = ActiveWorkbook
With Wb.Sheets("ABC1")
Set Rng = .Range(.[A11], .[K65000].End(3))
Set Dic = CreateObject("Scripting.Dictionary")
Arr = .Range(.[K12], [K65000].End(3)).Value
For I = 1 To UBound(Arr)
Tem = Arr(I, 1)
If Tem <> Empty And Not Dic.exists(Tem) Then
Item = Tem
Rng.AutoFilter 11, Item
.Range(.[A1], Rng).SpecialCells(12).Copy
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Item
Sheets(Item).[A1].PasteSpecial xlPasteValues
Sheets(Item).[A1].PasteSpecial xlPasteFormats
End If
Next I
.Activate
.AutoFilterMode = False
End With
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

Lần chỉnh sửa cuối:
Dữ liệu và code không ăn nhập gì cả, vậy viết code theo dữ liệu hay dữ liệu chạy theo code.
 

File đính kèm

Đặt tên Sheet mà lấy cột K là không phù hợp do trong tên có khi có những ký tự Excel không cho phép đặt tên chính vì vậy nó sẽ gặp lỗi tại chổ thay đổi tên sheet.
 
Tui viết cho bạn tham khảo còn tùy biến file của bạn thôi.
Mã: 
Public Sub GPE()
    Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
    Dim aWs As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
    If Ws.Name <> "ABC1" Then Ws.Delete
    Next Ws
    Set Wb = ActiveWorkbook
    With Wb.Sheets("ABC1")
        Set Rng = .Range(.[A11], .[K65000].End(3))
        Set Dic = CreateObject("Scripting.Dictionary")
        Arr = .Range(.[K11], [K65000].End(3)).Value
        For I = 1 To UBound(Arr)
            Tem = Arr(I, 1)
            If (Tem <> Empty) And (Not Dic.exists(Tem)) Then
                Item = Tem
                Dic.Add Tem, Tem
                Rng.AutoFilter 11, Item
                .Range(.[A1], Rng).SpecialCells(12).Copy
                Set aWs = Sheets.Add(After:=Sheets(Sheets.Count))
                aWs.Name = "Item" & I
                aWs.[A1].PasteSpecial xlPasteValues
                aWs.[A1].PasteSpecial xlPasteFormats
            End If
        Next I
        '.Activate
        .AutoFilterMode = False
        Set Dic = Nothing
    End With
    Set aWs = Nothing
    Set Wb = Nothing
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
hungmanh.th1 đã viết:
Mình làm một vi dụ cột F nó cũng báo vậy bạn à.:(
Nhấp chuột vào đây để mở rộng...
Thử code cái cột F vs ít cột hơn vẫn vậy bạn ạ
Bài đã được tự động gộp:

giaiphap đã viết:
Tui viết cho bạn tham khảo còn tùy biến file của bạn thôi.
Mã: 
Public Sub GPE()
    Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
    Dim aWs As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
    If Ws.Name <> "ABC1" Then Ws.Delete
    Next Ws
    Set Wb = ActiveWorkbook
    With Wb.Sheets("ABC1")
        Set Rng = .Range(.[A11], .[K65000].End(3))
        Set Dic = CreateObject("Scripting.Dictionary")
        Arr = .Range(.[K11], [K65000].End(3)).Value
        For I = 1 To UBound(Arr)
            Tem = Arr(I, 1)
            If (Tem <> Empty) And (Not Dic.exists(Tem)) Then
                Item = Tem
                Dic.Add Tem, Tem
                Rng.AutoFilter 11, Item
                .Range(.[A1], Rng).SpecialCells(12).Copy
                Set aWs = Sheets.Add(After:=Sheets(Sheets.Count))
                aWs.Name = "Item" & I
                aWs.[A1].PasteSpecial xlPasteValues
                aWs.[A1].PasteSpecial xlPasteFormats
            End If
        Next I
        '.Activate
        .AutoFilterMode = False
        Set Dic = Nothing
    End With
    Set aWs = Nothing
    Set Wb = Nothing
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn .Để mình thử cám ơn
 

File đính kèm

  • image.jpg
    image.jpg
    105.1 KB · Đọc: 5
Lần chỉnh sửa cuối:
giaiphap đã viết:
Tui viết cho bạn tham khảo còn tùy biến file của bạn thôi.
Mã: 
Public Sub GPE()
    Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
    Dim aWs As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
    If Ws.Name <> "ABC1" Then Ws.Delete
    Next Ws
    Set Wb = ActiveWorkbook
    With Wb.Sheets("ABC1")
        Set Rng = .Range(.[A11], .[K65000].End(3))
        Set Dic = CreateObject("Scripting.Dictionary")
        Arr = .Range(.[K11], [K65000].End(3)).Value
        For I = 1 To UBound(Arr)
            Tem = Arr(I, 1)
            If (Tem <> Empty) And (Not Dic.exists(Tem)) Then
                Item = Tem
                Dic.Add Tem, Tem
                Rng.AutoFilter 11, Item
                .Range(.[A1], Rng).SpecialCells(12).Copy
                Set aWs = Sheets.Add(After:=Sheets(Sheets.Count))
                aWs.Name = "Item" & I
                aWs.[A1].PasteSpecial xlPasteValues
                aWs.[A1].PasteSpecial xlPasteFormats
            End If
        Next I
        '.Activate
        .AutoFilterMode = False
        Set Dic = Nothing
    End With
    Set aWs = Nothing
    Set Wb = Nothing
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn cho mình số để add zalo nha
 
giaiphap đã viết:
Tui viết cho bạn tham khảo còn tùy biến file của bạn thôi.
Mã: 
Public Sub GPE()
    Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
    Dim aWs As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
    If Ws.Name <> "ABC1" Then Ws.Delete
    Next Ws
    Set Wb = ActiveWorkbook
    With Wb.Sheets("ABC1")
        Set Rng = .Range(.[A11], .[K65000].End(3))
        Set Dic = CreateObject("Scripting.Dictionary")
        Arr = .Range(.[K11], [K65000].End(3)).Value
        For I = 1 To UBound(Arr)
            Tem = Arr(I, 1)
            If (Tem <> Empty) And (Not Dic.exists(Tem)) Then
                Item = Tem
                Dic.Add Tem, Tem
                Rng.AutoFilter 11, Item
                .Range(.[A1], Rng).SpecialCells(12).Copy
                Set aWs = Sheets.Add(After:=Sheets(Sheets.Count))
                aWs.Name = "Item" & I
                aWs.[A1].PasteSpecial xlPasteValues
                aWs.[A1].PasteSpecial xlPasteFormats
            End If
        Next I
        '.Activate
        .AutoFilterMode = False
        Set Dic = Nothing
    End With
    Set aWs = Nothing
    Set Wb = Nothing
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn oi !Công thức này tách thành từng sheets rùi nhưng lại ko theo địa chỉ.Mà 60 dòng thành 60 sheets luôn bạn à. Mình muốn lấy trị chung ví dụ từng huyện như hình á bạn à
1667719326751.png
 
Lần chỉnh sửa cuối:
hungmanh.th1 đã viết:
Hinnf nhuw banj HD mình thêm .Dic Add ITem, "" đúng ko
Nhấp chuột vào đây để mở rộng...
Code bạn đang viết có đoạn kiểm tra sự tồn tại của tên sheet trong dictionary
PHP: 
 If Tem <> Empty And Not Dic.exists(Tem)
Nhưng dòm hoài thì không thấy có chỗ nào bạn đưa giá trị vào trong Dic, vậy thì cứ so sánh với tập rỗng ? thì mặc nhiên là Not Exist luôn đúng. Bạn thêm dòng
PHP: 
 Dic.Add Item, ""
Nhưng mà góp ý là bạn đặt tên Sheet bằng tên công ty thì, vừa khó quản lý, vừa dễ lỗi nếu tên công ty có chứa ký tự đặc biệt. Theo mình nên bổ sung tờ mục lục chứa tên mã (hoặc tên rút gọn) và tên đầy đủ, dùng mã để đặt tên sheet, dùng Hyperlink để nhảy đến sheet sẽ tiện quản lý luôn.
 
huhumalu đã viết:
Code bạn đang viết có đoạn kiểm tra sự tồn tại của tên sheet trong dictionary
PHP: 
 If Tem <> Empty And Not Dic.exists(Tem)
Nhưng dòm hoài thì không thấy có chỗ nào bạn đưa giá trị vào trong Dic, vậy thì cứ so sánh với tập rỗng ? thì mặc nhiên là Not Exist luôn đúng. Bạn thêm dòng
PHP: 
 Dic.Add Item, ""
Nhưng mà góp ý là bạn đặt tên Sheet bằng tên công ty thì ...
Nhấp chuột vào đây để mở rộng...
Thêm đoạn này vào trước THen thì nó báo sai câu lệnh bạn à Dic.Add ITem, ""
 
1667724377132.png
Mình thêm vào đoạn này.

PHP: 
Public Sub GPE()
    Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name <> "ABC1" Then Ws.Delete
    Next Ws
    Set Wb = ActiveWorkbook
    With Wb.Sheets("ABC1")
        Set Rng = .Range(.[A11], .[K65000].End(3))
        Set Dic = CreateObject("Scripting.Dictionary")
        Arr = .Range(.[K12], [K65000].End(3)).Value
        For I = 1 To UBound(Arr)
            Tem = Arr(I, 1)
            If Tem <> Empty And Not Dic.exists(Tem) Then
            Item = Tem
                Dic.Add Tem, ""
                'Dic.Add Item, ""
                Rng.AutoFilter 11, Item
                .Range(.[A1], Rng).SpecialCells(12).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Item
                Sheets(Item).[A1].PasteSpecial xlPasteValues
                Sheets(Item).[A1].PasteSpecial xlPasteFormats
            End If
        Next I
        .Activate
        .AutoFilterMode = False
    End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
huhumalu đã viết:
View attachment 283042
Mình thêm vào đoạn này.

PHP: 
Public Sub GPE()
    Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name <> "ABC1" Then Ws.Delete
    Next Ws
    Set Wb = ActiveWorkbook
    With Wb.Sheets("ABC1")
        Set Rng = .Range(.[A11], .[K65000].End(3))
        Set Dic = CreateObject("Scripting.Dictionary")
        Arr = .Range(.[K12], [K65000].End(3)).Value
        For I = 1 To UBound(Arr)
            Tem = Arr(I, 1)
            If Tem <> Empty And Not Dic.exists(Tem) Then
            Item = Tem
                Dic.Add Tem, ""
                'Dic.Add Item, ""
                Rng.AutoFilter 11, Item
                .Range(.[A1], Rng).SpecialCells(12).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Item
                Sheets(Item).[A1].PasteSpecial xlPasteValues
                Sheets(Item).[A1].PasteSpecial xlPasteFormats
            End If
        Next I
        .Activate
        .AutoFilterMode = False
    End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
1667786527340.png

Bạn ơi. Nếu mình muốn hiển thị tên đv, mã số thuế, địa chỉ........................... để chạy theo các sheets khi xuất ra có được không bạn :)
 
huhumalu đã viết:
View attachment 283042
Mình thêm vào đoạn này.

PHP: 
Public Sub GPE()
    Dim I, Arr, Dic As Object, Tem, Item As String, Wb As Object, Rng As Range, Ws As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name <> "ABC1" Then Ws.Delete
    Next Ws
    Set Wb = ActiveWorkbook
    With Wb.Sheets("ABC1")
        Set Rng = .Range(.[A11], .[K65000].End(3))
        Set Dic = CreateObject("Scripting.Dictionary")
        Arr = .Range(.[K12], [K65000].End(3)).Value
        For I = 1 To UBound(Arr)
            Tem = Arr(I, 1)
            If Tem <> Empty And Not Dic.exists(Tem) Then
            Item = Tem
                Dic.Add Tem, ""
                'Dic.Add Item, ""
                Rng.AutoFilter 11, Item
                .Range(.[A1], Rng).SpecialCells(12).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Item
                Sheets(Item).[A1].PasteSpecial xlPasteValues
                Sheets(Item).[A1].PasteSpecial xlPasteFormats
            End If
        Next I
        .Activate
        .AutoFilterMode = False
    End With
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Mình hỏi chút ! Mình chạy file nhưng cứ chạy ra cái dòng đầu tiên của trang tính 1. Sheets nào cũng có dòng này. Bạn chỉ mình sửa lại CT với
1667791881942.png
1667791908161.png
1667791924925.png
 
Do bạn set AutoFilter vào dòng thứ 11.
bạn đổi
PHP: 
Set Rng = .Range(.[A11], .[K65000].End(3))
thành
PHP: 
Set Rng = .Range(.[A10], .[K65000].End(3))
 
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

micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA (1 người xem)
Trả lời
2
Đọc
595
tranduc36
T
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
13
Đọc
103
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
175
Gà Công Nghệ
Gà Công Nghệ
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt (1 người xem)
    • Thích
    • Yêu thích
2
Trả lời
20
Đọc
1K
Mr.hieudoanxd
Mr.hieudoanxd
P
Excell code vba : Tìm Cell để sửa dữ liệu
    • Buồn
2
Trả lời
26
Đọc
523
Phạm Trường 80
P
L
Lỗi font khi convert từ pdf
Trả lời
1
Đọc
56
Hoàng Tuấn 868
H
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
77
SA_DQ
SA_DQ
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup (1 người xem)
Trả lời
2
Đọc
75
DeTong
D
H
Đổi số thành chữ trong office 365
Trả lời
19
Đọc
1K
HoangTan891026
H
Gà Công Nghệ
Lấy dữ liệu file excel từ sheet này sang sheet khác
Trả lời
4
Đọc
129
Gà Công Nghệ
Gà Công Nghệ
N
Mong mọi người giúp đỡ
Trả lời
1
Đọc
59
minhminh27
minhminh27
minhduc1o2
Excel lỗi font Time New Roman+
Trả lời
7
Đọc
116
minhduc1o2
minhduc1o2
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
0
Đọc
75
fujishima
F
H
Lọc dữ liệu trong XL
    • Cười
Trả lời
0
Đọc
46
huong.dinh
H
giaiphap
Add-Ins hổ trợ Word trộn danh sách và lưu ra nhiều tệp tin khác nhau.
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
39
Đọc
9K
fujishima
F
K
xin file excel bảng đấu bóng đá (1 người xem)
    • Yêu thích
2 3
Trả lời
40
Đọc
25K
subin1905
S
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
24
Đọc
7K
chihuumvc
C
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
1
Đọc
66
bebo021999
B
G
Hướng dẫn Lập danh sách File
    • Không thích
Trả lời
16
Đọc
269
thanhhuy_hvnh
thanhhuy_hvnh
baolong240793
Nhờ Anh/Chị hỗ trợ em hàm Randbetween() với ạ.
Trả lời
4
Đọc
362
bebo021999
B
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom