Giúp code lấy tên và đuôi từ 1 danh sách cho trước

Liên hệ QC
minhtuan55

minhtuan55

Thành viên bị đình chỉ hoạt động
Thành viên bị đình chỉ hoạt động
Tham gia
23/3/16
Bài viết
705
Được thích
52
Chào cả nhà GPE . CHúc tất cả mọi người năm mới sức khỏe , làm ăn phát tài, hoan hĩ, từ bi, thanh tịnh..
Em có 1 danh sách gồm Full đường dẫn như ảnh ( tầm 5000 dòng ) . Em muốn code lấy tên và đuôi thôi, Em không muốn dùng công thức vì nặng file
Xin chân thành cảm ơn !

1551140020949.png
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Thử code này nhé!
Sub tachduoi()
For Each c In Range([A1], [A65000].End(xlUp))
c.Offset(, 1) = Mid(c, InStrRev(c, "\") + 1)
Next c
End Sub
 
Upvote 0
minhtuan55 đã viết:
Chào cả nhà GPE . CHúc tất cả mọi người năm mới sức khỏe , làm ăn phát tài, hoan hĩ, từ bi, thanh tịnh..
Em có 1 danh sách gồm Full đường dẫn như ảnh ( tầm 5000 dòng ) . Em muốn code lấy tên và đuôi thôi, Em không muốn dùng công thức vì nặng file
Xin chân thành cảm ơn !

View attachment 212729
Nhấp chuột vào đây để mở rộng...
Code cho bạn
Mã: 
Sub GPE()
    Dim sArr(), Res(), lR As Long, K As Long, I As Long
    
    lR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    sArr() = Sheet1.Range("A2:A" & lR).Value
    ReDim Res(1 To UBound(sArr, 1), 1 To 1)
    
    For I = 1 To UBound(sArr, 1)
        K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
    
    Sheet1.Range("B2").Resize(K) = Res
End Sub
 
Upvote 0
vanthinh3101 đã viết:
Code cho bạn
Mã: 
Sub GPE()
    Dim sArr(), Res(), lR As Long, K As Long, I As Long
   
    lR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    sArr() = Sheet1.Range("A2:A" & lR).Value
    ReDim Res(1 To UBound(sArr, 1), 1 To 1)
   
    For I = 1 To UBound(sArr, 1)
        K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
   
    Sheet1.Range("B2").Resize(K) = Res
End Sub
Nhấp chuột vào đây để mở rộng...

Code chạy bị lỗi anh ơi. Mong anh Fix dùm. Cảm ơn anh
1551166331402.png
Bài đã được tự động gộp:

quanghai1969 đã viết:
Bài này record macro thì ra vầy

Sub Macro1()
Columns("A:A").Replace "*\", ""
End Sub
Nhấp chuột vào đây để mở rộng...

Ý là sau chạy xong code thì cột A vẫn giữ nguyên dữ liệu gốc anh. còn dữ liệu Output xuất ra cột B
 
Upvote 0
vanthinh3101 đã viết:
Lỗi báo thế nào bạn nhỉ?
Nhấp chuột vào đây để mở rộng...

1551176710857.png

Em muốn chổ Input e tự chỉnh được đầu Vào. nếu dử liệu trống thì Ouput trống luôn chứ đừng báo lỗi

Sub GPE()
Dim sArr(), Res(), K As Long, I As Long
sArr() = Sheet1.Range("A2:A100").Value ' Em muon cho Nay tuy chinh
ReDim Res(1 To UBound(sArr, 1), 1 To 1)

For I = 1 To UBound(sArr, 1)
K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I

Sheet1.Range("B2").Resize(K) = Res
End Sub


Dòng màu vàng
 
Upvote 0
minhtuan55 đã viết:
View attachment 212792

Em muốn chổ Input e tự chỉnh được đầu Vào. nếu dử liệu trống thì Ouput trống luôn chứ đừng báo lỗi

Sub GPE()
Dim sArr(), Res(), K As Long, I As Long
sArr() = Sheet1.Range("A2:A100").Value ' Em muon cho Nay tuy chinh
ReDim Res(1 To UBound(sArr, 1), 1 To 1)

For I = 1 To UBound(sArr, 1)
K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I

Sheet1.Range("B2").Resize(K) = Res
End Sub


Dòng màu vàng
Nhấp chuột vào đây để mở rộng...
Bạn thử code sau:
PHP: 
Sub GPE()
    Dim sArr(), Res(), Tmp, K As Long, I As Long
    Dim sRng As Range, rRng As Range
    
    'Chon vung du lieu dau vao
    Set sRng = InputBox
    If Not sRng Is Nothing Then
        sArr() = sRng.Value
        ReDim Res(1 To UBound(sArr, 1), 1 To 1)
        
        For I = 1 To UBound(sArr, 1)
            K = K + 1
            If Len(sArr(I, 1)) Then
                Tmp = Split(sArr(I, 1), "\")
                Res(K, 1) = Tmp(UBound(Tmp))
            Else
                Res(K, 1) = ""
            End If
        Next I
        
        'Chon vung dien ket qua
        Set rRng = InputBox
        If Not rRng Is Nothing Then
            rRng(1, 1).Resize(K) = Res
            Set sRng = Nothing: Set rRng = Nothing
            MsgBox "Done", vbInformation, "GPE"
        End If
    End If
End Sub

Function InputBox() As Range
    On Error GoTo Err
    Set InputBox = Application.InputBox("Please choose your range:", "GPE", Type:=8)
    Exit Function
Err:
    Set InputBox = Nothing
End Function
 
Upvote 0
vanthinh3101 đã viết:
Bạn thử code sau:
PHP: 
Sub GPE()
    Dim sArr(), Res(), Tmp, K As Long, I As Long
    Dim sRng As Range, rRng As Range

    'Chon vung du lieu dau vao
    Set sRng = InputBox
    If Not sRng Is Nothing Then
        sArr() = sRng.Value
        ReDim Res(1 To UBound(sArr, 1), 1 To 1)
    
        For I = 1 To UBound(sArr, 1)
            K = K + 1
            If Len(sArr(I, 1)) Then
                Tmp = Split(sArr(I, 1), "\")
                Res(K, 1) = Tmp(UBound(Tmp))
            Else
                Res(K, 1) = ""
            End If
        Next I
    
        'Chon vung dien ket qua
        Set rRng = InputBox
        If Not rRng Is Nothing Then
            rRng(1, 1).Resize(K) = Res
            Set sRng = Nothing: Set rRng = Nothing
            MsgBox "Done", vbInformation, "GPE"
        End If
    End If
End Sub

Function InputBox() As Range
    On Error GoTo Err
    Set InputBox = Application.InputBox("Please choose your range:", "GPE", Type:=8)
    Exit Function
Err:
    Set InputBox = Nothing
End Function
Nhấp chuột vào đây để mở rộng...

Thank anh rất hay. Nhưng mà em không hiện cái Input để chọn vùng đó. Nó hết sức là đơn giản. Nó phải như đoạn code bài này
Mã: 
Sub GPE()
Dim sArr(), Res(), K As Long, I As Long
sArr() = Sheet1.Range("A2:A100").Value ' Em muon cho Nay tuy chinh
ReDim Res(1 To UBound(sArr, 1), 1 To 1)

For I = 1 To UBound(sArr, 1)
K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I

Sheet1.Range("B2").Resize(K) = Res
End Sub

Nhưng code trên có nhược điểm là nó báo lỗi ở đoạn sArr() = Sheet1.Range("A2:A100").Value ( Khi dữ liệu trống ). Em muốn trống thì xuất ra trống luôn
Ví dụ dữ liệu của em từ A2:A50 ( có text đường dẫn ) mà cái sArr() =A2:A100 thì B2:B50 thì xuất ra dữ liệu còn B51:B100 xuất ra trống trống.
 
Upvote 0
minhtuan55 đã viết:
Thank anh rất hay. Nhưng mà em không hiện cái Input để chọn vùng đó. Nó hết sức là đơn giản. Nó phải như đoạn code bài này
Mã: 
Sub GPE()
Dim sArr(), Res(), K As Long, I As Long
sArr() = Sheet1.Range("A2:A100").Value ' Em muon cho Nay tuy chinh
ReDim Res(1 To UBound(sArr, 1), 1 To 1)

For I = 1 To UBound(sArr, 1)
K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I

Sheet1.Range("B2").Resize(K) = Res
End Sub

Nhưng code trên có nhược điểm là nó báo lỗi ở đoạn sArr() = Sheet1.Range("A2:A100").Value ( Khi dữ liệu trống ). Em muốn trống thì xuất ra trống luôn
Ví dụ dữ liệu của em từ A2:A50 ( có text đường dẫn ) mà cái sArr() =A2:A100 thì B2:B50 thì xuất ra dữ liệu còn B51:B100 xuất ra trống trống.
Nhấp chuột vào đây để mở rộng...
Bạn nói bạn muốn tùy chỉnh dữ liệu đầu vào nên tôi đã sử dụng Inputbox cho bạn tự chọn rồi đó.
Còn nếu có vùng khác thì bạn có thể tự sửa vào code cũng được.
Còn gặp dữ liệu trống thì code ở bài #12 tôi đã đưa thêm điều kiện dữ liệu trống thì kết quả trống rồi.
PHP: 
If Len(sArr(I, 1)) Then
    Tmp = Split(sArr(I, 1), "\")
    Res(K, 1) = Tmp(UBound(Tmp))
Else
    Res(K, 1) = ""
End If
 
Upvote 0
vanthinh3101 đã viết:
Bạn nói bạn muốn tùy chỉnh dữ liệu đầu vào nên tôi đã sử dụng Inputbox cho bạn tự chọn rồi đó.
Còn nếu có vùng khác thì bạn có thể tự sửa vào code cũng được.
Còn gặp dữ liệu trống thì code ở bài #12 tôi đã đưa thêm điều kiện dữ liệu trống thì kết quả trống rồi.
PHP: 
If Len(sArr(I, 1)) Then
    Tmp = Split(sArr(I, 1), "\")
    Res(K, 1) = Tmp(UBound(Tmp))
Else
    Res(K, 1) = ""
End If
Nhấp chuột vào đây để mở rộng...

Dạ em rất cảm ơn anh. Chắc có thể anh không hiễu ý e. Bây giờ em sẽ nói lại 1 lần nữa a đọc sẽ hiểu rất mong anh giúp cho trót
Bây giờ đoạn code anh nó chạy đúng nếu em thay đổi code như thế này ( Xem ảnh bên dưới ) Do từ A2:A7 có dữ liệu nên code OK



1551241719988.png



Bây giờ em thay đổi lại đầu vào là A2:A100 mà từ A2:A7 lại có dữ liệu còn từ A8:A100 trở đi là trống. Thì từ B2:B7 vẫn xuất ra như cũ và từ B8:B100 thì xuất ra trống ( do A8:A100 trống thì xuất ra trống )


1551241931408.png


Vùng dữ liệu em cố định từ A2:A100 và có dòng trống có dòng có. nến không thể dùng
Sheet1.Range("A" & Rows.Count).End(xlUp).Row
 
Lần chỉnh sửa cuối:
Upvote 0
minhtuan55 đã viết:
Dạ em rất cảm ơn anh. Chắc có thể anh không hiễu ý e. Bây giờ em sẽ nói lại 1 lần nữa a đọc sẽ hiểu rất mong anh giúp cho trót
Bây giờ đoạn code anh nó chạy đúng nếu em thay đổi code như thế này ( Xem ảnh bên dưới ) Do từ A2:A7 có dữ liệu nên code OK



View attachment 212820



Bây giờ em thay đổi lại đầu vào là A2:A100 mà từ A2:A7 lại có dữ liệu còn từ A8:A100 trở đi là trống. Thì từ B2:B7 vẫn xuất ra như cũ và từ B8:B100 thì xuất ra trống ( do A8:A100 trống thì xuất ra trống )


View attachment 212821


Vùng dữ liệu em cố định từ A2:A100 và có dòng trống có dòng có. nến không thể dùng
Sheet1.Range("A" & Rows.Count).End(xlUp).Row
Nhấp chuột vào đây để mở rộng...
Bạn sửa đoạn này:
PHP: 
For I = 1 To UBound(sArr, 1)
    K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
Thành:
PHP: 
For I = 1 To UBound(sArr, 1)
    K = K + 1
    If len(sArr(I,1)) Then
        Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Else
        Res(K,1)=""
    End If
Next I
 
Upvote 0
vanthinh3101 đã viết:
Bạn sửa đoạn này:
PHP: 
For I = 1 To UBound(sArr, 1)
    K = K + 1: Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
Thành:
PHP: 
For I = 1 To UBound(sArr, 1)
    K = K + 1
    If len(sArr(I,1)) Then
        Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Else
        Res(K,1)=""
    End If
Next I
Nhấp chuột vào đây để mở rộng...
Chỉ cần
Mã: 
For I = 1 To UBound(sArr, 1)
    K = K + 1
    If Len(sArr(I, 1)) Then Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
bởi mảng Res được khởi tạo với các element = Empty rồi.

Nhưng dùng thêm K để làm gì? Từ code thấy luôn luôn có K = I. Vậy chỉ cần
Mã: 
For I = 1 To UBound(sArr, 1)
    If Len(sArr(I, 1)) Then Res(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
Và toàn bộ code theo cách của bạn là
Mã: 
Sub GPE()
Dim sArr(), Res(), I As Long
    sArr = Range("A2:A100").Value
    ReDim Res(1 To UBound(sArr, 1), 1 To 1)
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) Then Res(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
    Range("B2").Resize(UBound(Res)) = Res
End Sub

Nhưng vẫn thừa. Dùng Res làm gì?
Vẫn theo cách của bạn thì
Mã: 
Sub GPE()
Dim sArr(), I As Long
    sArr = Range("A2:A100").Value
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) Then sArr(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
    Range("B2").Resize(UBound(sArr)) = sArr
End Sub
 
Upvote 0
batman1 đã viết:
Chỉ cần
Mã: 
For I = 1 To UBound(sArr, 1)
    K = K + 1
    If Len(sArr(I, 1)) Then Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
bởi mảng Res được khởi tạo với các element = Empty rồi.

Nhưng dùng thêm K để làm gì? Từ code thấy luôn luôn có K = I. Vậy chỉ cần
Mã: 
For I = 1 To UBound(sArr, 1)
    If Len(sArr(I, 1)) Then Res(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
Và toàn bộ code theo cách của bạn là
Mã: 
Sub GPE()
Dim sArr(), Res(), I As Long
    sArr = Range("A2:A100").Value
    ReDim Res(1 To UBound(sArr, 1), 1 To 1)
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) Then Res(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
    Range("B2").Resize(UBound(Res)) = Res
End Sub

Nhưng vẫn thừa. Dùng Res làm gì?
Vẫn theo cách của bạn thì
Mã: 
Sub GPE()
Dim sArr(), I As Long
    sArr = Range("A2:A100").Value
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) Then sArr(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
    Range("B2").Resize(UBound(sArr)) = sArr
End Sub
Nhấp chuột vào đây để mở rộng...
Em cám ơn bác đã chỉ bảo.
Đúng là "nói dài, nói dai thành ra nói dại"
 
Upvote 0
batman1 đã viết:
Chỉ cần
Mã: 
For I = 1 To UBound(sArr, 1)
    K = K + 1
    If Len(sArr(I, 1)) Then Res(K, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
bởi mảng Res được khởi tạo với các element = Empty rồi.

Nhưng dùng thêm K để làm gì? Từ code thấy luôn luôn có K = I. Vậy chỉ cần
Mã: 
For I = 1 To UBound(sArr, 1)
    If Len(sArr(I, 1)) Then Res(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
Next I
Và toàn bộ code theo cách của bạn là
Mã: 
Sub GPE()
Dim sArr(), Res(), I As Long
    sArr = Range("A2:A100").Value
    ReDim Res(1 To UBound(sArr, 1), 1 To 1)
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) Then Res(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
    Range("B2").Resize(UBound(Res)) = Res
End Sub

Nhưng vẫn thừa. Dùng Res làm gì?
Vẫn theo cách của bạn thì
Mã: 
Sub GPE()
Dim sArr(), I As Long
    sArr = Range("A2:A100").Value
    For I = 1 To UBound(sArr, 1)
        If Len(sArr(I, 1)) Then sArr(I, 1) = Split(sArr(I, 1), "\")(UBound(Split(sArr(I, 1), "\")))
    Next I
    Range("B2").Resize(UBound(sArr)) = sArr
End Sub
Nhấp chuột vào đây để mở rộng...


Em xin báo cáo code của bác em Test hơn 1 tiếng đồng hồ với 23 trường hợp 5 ngôn ngữ. Và cái kết là tìm X mới có đáp án ( Giải trí thôi nha bác )
1551256476874.png
 
Upvote 0
minhtuan55 đã viết:
Em xin báo cáo code của bác em Test hơn 1 tiếng đồng hồ với 23 trường hợp 5 ngôn ngữ. Và cái kết là tìm X mới có đáp án ( Giải trí thôi nha bác )
Nhấp chuột vào đây để mở rộng...
Đấy có phải code của tôi đâu? Tôi chỉ rút gọn nó để 2 code (trước và sau khi rút gọn) chạy ra kết quả y hệt nhau. Tức nếu đúng thì cùng đúng, nếu sai thì cùng sai.

Tôi viết rõ mà
Và toàn bộ code theo cách của bạn là
...
Vẫn theo cách của bạn thì
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
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

dinhnhat91
  • Question Question
VBA Lỗi runtime error 9 subscript out of range
Trả lời
4
Đọc
73
ongke0711
ongke0711
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
1
Đọc
510
PhanTuHuong
PhanTuHuong
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
0
Đọc
50
Việt Nguyễn 86
Việt Nguyễn 86
K
Mong giúp dữ liệu từ trang web sang excel
Trả lời
0
Đọc
51
khanhvinhdai1
K
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
3
Đọc
1K
trung_bhxh
T
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
Trả lời
0
Đọc
77
trung_bhxh
T
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
52
Đọc
103K
khanhvinhdai1
K
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
3
Đọc
1K
Skyler113
Skyler113
Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
5
Đọc
109
ptm0412
ptm0412
Huyen9
Lỗi không mailings được.
Trả lời
3
Đọc
85
vanle33
vanle33
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
310
Đọc
23K
kunkoi9390
K
K
Có ai giúp mình lấy kết quả xổ số miền nam về file excel
Trả lời
0
Đọc
43
khanhvinhdai1
K
ptm0412
  • Question Question
Lấy dữ liệu web nhiều trang về file Excel bằng Power Query
    • Thích
Trả lời
5
Đọc
2K
ptm0412
ptm0412
H
Công thức tìm kết quả
Trả lời
11
Đọc
124
VetMini
V
V
Hàm dò tìm lấy giá trị của lần xuất hiện thứ n trong excel.
Trả lời
9
Đọc
1K
VetMini
V
N
Nhờ các anh chỉ chỉnh lỗi giúp em với ạ, em cảm ơn ạ.
Trả lời
3
Đọc
83
minhminh27
minhminh27
T
File quản lý thiết bị trong trường học!
Trả lời
4
Đọc
140
VetMini
V
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
1
Đọc
135
VetMini
V
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
3
Đọc
135
VetMini
V
hungtin1997
  • Question Question
[Hỏi] Tạo Hyperlink đến ô chạy ngang theo cột
Trả lời
6
Đọc
422
A HOANG 620
A
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom