Tách chuỗi bằng code VBA

Liên hệ QC

thao nguyen01

Thành viên thường trực
Tham gia
8/12/19
Bài viết
214
Được thích
25
Kính gửi anh/chị trên diễn đàn,

Em đang bị vướng về vấn đề tách chuỗi ạ. Em muốn tách tên và chứng minh nhân dân từ cột A ạ. Em có mô tả trong file đính kèm. Anh/chị xem giúp em với ạ. Em cảm ơn ạ.
 

File đính kèm

  • Book1.xlsb
    8.3 KB · Đọc: 17
Kính gửi anh/chị trên diễn đàn,

Em đang bị vướng về vấn đề tách chuỗi ạ. Em muốn tách tên và chứng minh nhân dân từ cột A ạ. Em có mô tả trong file đính kèm. Anh/chị xem giúp em với ạ. Em cảm ơn ạ.
Bạn thử:
PHP:
Sub Test()
    Dim Cll As Range
    For Each Cll In Range("A2", Range("A" & Rows.Count).End(xlUp))
        Cll.Offset(, 1).Value = Replace(Replace(Replace(Split(Cll.Value, ":")(0), "CCCD", ""), "CMND", ""), ",", "")
        Cll.Offset(, 2).Value = Split(Cll.Value, ":")(1)
    Next Cll
End Sub
 

File đính kèm

  • TACH.xls
    45.5 KB · Đọc: 9
Upvote 0
Kính gửi anh/chị trên diễn đàn,

Em đang bị vướng về vấn đề tách chuỗi ạ. Em muốn tách tên và chứng minh nhân dân từ cột A ạ. Em có mô tả trong file đính kèm. Anh/chị xem giúp em với ạ. Em cảm ơn ạ.
Nếu dữ liệu của bạn tổ chức 1 cách thống nhất thì có thể sử dụng chức năng Text to columns 2 lần. Nhanh gọn mà không cần tới công thức hay VBA
1585194178234.png
1585194145606.png
View attachment 234066View attachment 234067
 
Upvote 0
Nếu dữ liệu của bạn tổ chức 1 cách thống nhất thì có thể sử dụng chức năng Text to columns 2 lần. Nhanh gọn mà không cần tới công thức hay VBA
View attachment 234069
View attachment 234068
View attachment 234066View attachment 234067

Dạ, em cảm ơn ạ.
Bài đã được tự động gộp:

Bạn thử:
PHP:
Sub Test()
    Dim Cll As Range
    For Each Cll In Range("A2", Range("A" & Rows.Count).End(xlUp))
        Cll.Offset(, 1).Value = Replace(Replace(Replace(Split(Cll.Value, ":")(0), "CCCD", ""), "CMND", ""), ",", "")
        Cll.Offset(, 2).Value = Split(Cll.Value, ":")(1)
    Next Cll
End Sub

Dạ, em cảm ơn ạ. Nhưng khi em chạy code Ví dụ: CCCD: 027071123078, thì khi chạy xong thiếu mất số 0 ở đầu ạ. Anh/chị có thể xem giúp em với ạ. Em cảm ơn ạ.
 
Upvote 0
Mình chọt chẹt them 1 cách. Bạn tham khảo
PHP:
Sub Tachdulieu()
    Dim sRng As Range, rng As Range
    Dim sArr(), dArr(), I As Long, K As Long
    On Error GoTo Thoat
    Set sRng = Application.InputBox(Prompt:="chon vung du lieu ", Title:="Chon du lieu dau vao", Type:=8)
    sArr = sRng.Value
    ReDim dArr(1 To UBound(sArr), 1 To 2)
    For I = 1 To UBound(sArr)
        If sArr(I, 1) <> Empty Then
            sArr(I, 1) = Replace(sArr(I, 1), ",", ""):    sArr(I, 1) = Replace(sArr(I, 1), ";", "")
            sArr(I, 1) = Replace(sArr(I, 1), "CMND", ""):    sArr(I, 1) = Replace(sArr(I, 1), "CCCD", "")
            K = K + 1
            On Error Resume Next
            dArr(K, 1) = Split(sArr(I, 1), ":")(0): dArr(K, 2) = Split(sArr(I, 1), ":")(1)
        End If
    Next I
    Set rng = Application.InputBox(Prompt:="Chon o chua ket qua", Title:="Chon o", Type:=8)
    rng.Resize(K, 2) = dArr
Thoat:
End Sub
 

File đính kèm

  • Book1 (1).xlsb
    17.8 KB · Đọc: 11
Upvote 0
Kính gửi anh/chị trên diễn đàn,

Em đang bị vướng về vấn đề tách chuỗi ạ. Em muốn tách tên và chứng minh nhân dân từ cột A ạ. Em có mô tả trong file đính kèm. Anh/chị xem giúp em với ạ. Em cảm ơn ạ.
Thử code dưới đây
Mã:
Sub Tach()
Dim Nguon
Dim Kq() As String
Dim i, j, k, rws
With Sheet1
    rws = .Range("A1").End(xlDown).Row
    Nguon = .Range("A2:A" & rws)
    ReDim Kq(1 To rws - 1, 1 To 2)
    For i = 1 To rws - 1
        Nguon(i, 1) = Replace(Nguon(i, 1), ",", "")
        k = InStr(Nguon(i, 1), ":")
        Kq(i, 2) = Trim(Mid(Nguon(i, 1), k + 1, 100))
        k = InStrRev(Left(Nguon(i, 1), k - 1), " ")
        Kq(i, 1) = Trim(Left(Nguon(i, 1), k - 1))
    Next i
    .Range("B2").Resize(UBound(Kq), UBound(Kq, 2)).ClearContents
    .Range("B2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End With
End Sub
 
Upvote 0
Mình chọt chẹt them 1 cách. Bạn tham khảo
PHP:
Sub Tachdulieu()
    Dim sRng As Range, rng As Range
    Dim sArr(), dArr(), I As Long, K As Long
    On Error GoTo Thoat
    Set sRng = Application.InputBox(Prompt:="chon vung du lieu ", Title:="Chon du lieu dau vao", Type:=8)
    sArr = sRng.Value
    ReDim dArr(1 To UBound(sArr), 1 To 2)
    For I = 1 To UBound(sArr)
        If sArr(I, 1) <> Empty Then
            sArr(I, 1) = Replace(sArr(I, 1), ",", ""):    sArr(I, 1) = Replace(sArr(I, 1), ";", "")
            sArr(I, 1) = Replace(sArr(I, 1), "CMND", ""):    sArr(I, 1) = Replace(sArr(I, 1), "CCCD", "")
            K = K + 1
            dArr(K, 1) = Split(sArr(I, 1), ":")(0): dArr(K, 2) = Split(sArr(I, 1), ":")(1)
        End If
    Next I
    Set rng = Application.InputBox(Prompt:="Chon o chua ket qua", Title:="Chon o", Type:=8)
    rng.Resize(K, 2) = dArr
Thoat:
End Sub

Dạ, em cảm ơn ạ. Nhưng khi em chạy code bị vấn đề như trên ạ. Em Ví dụ: CCCD: 027071123078, thì khi chạy xong thiếu mất số 0 ở sub tachchuoi ạ. Anh xem giúp em ạ. Em cảm ơn ạ.
Bài đã được tự động gộp:

Thử code dưới đây
Mã:
Sub Tach()
Dim Nguon
Dim Kq() As String
Dim i, j, k, rws
With Sheet1
    rws = .Range("A1").End(xlDown).Row
    Nguon = .Range("A2:A" & rws)
    ReDim Kq(1 To rws - 1, 1 To 2)
    For i = 1 To rws - 1
        Nguon(i, 1) = Replace(Nguon(i, 1), ",", "")
        k = InStr(Nguon(i, 1), ":")
        Kq(i, 2) = Trim(Mid(Nguon(i, 1), k + 1, 100))
        k = InStrRev(Left(Nguon(i, 1), k - 1), " ")
        Kq(i, 1) = Trim(Left(Nguon(i, 1), k - 1))
    Next i
    .Range("B2").Resize(UBound(Kq), UBound(Kq, 2)).ClearContents
    .Range("B2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End With
End Sub

Dạ, kết quả ra đúng rồi ạ. Em cảm ơn anh ạ.
 
Upvote 0
Dạ, em cảm ơn ạ. Nhưng khi em chạy code bị vấn đề như trên ạ. Em Ví dụ: CCCD: 027071123078, thì khi chạy xong thiếu mất số 0 ở sub tachchuoi ạ. Anh xem giúp em ạ. Em cảm ơn ạ.
Bạn thay dòng cũ bang dòng này thử
Mã:
dArr(K, 1) = Split(sArr(I, 1), ":")(0): dArr(K, 2) = "'" & Split(sArr(I, 1), ":")(1)
 
Upvote 0
Dạ, vì dữ liệu của em 1 tháng gần 10.000 dòng, 1 năm hơn 100.000 dòng, nên em dùng hàm sẽ chậm ạ.
Quản lý dữ klieeuj chừng này thì đi học một khoá quản lý đi.
Điẻn hình là học cách quản lý csdl. Nếu vẫn còn dùng Excel thì cần học PowerQuery và Powerpivot.

Cốt kiếc này nọ chỉ là đắp vá tạm thời.
 
Upvote 0
Bạn thay dòng cũ bang dòng này thử
Mã:
dArr(K, 1) = Split(sArr(I, 1), ":")(0): dArr(K, 2) = "'" & Split(sArr(I, 1), ":")(1)

Dạ, kết quả ra đúng ạ. Em cảm ơn anh ạ.
Bài đã được tự động gộp:

Quản lý dữ klieeuj chừng này thì đi học một khoá quản lý đi.
Điẻn hình là học cách quản lý csdl. Nếu vẫn còn dùng Excel thì cần học PowerQuery và Powerpivot.

Cốt kiếc này nọ chỉ là đắp vá tạm thời.

Dạ, em cảm ơn Thầy ạ. Vì dữ liệu nhiều, nhưng lúc nhập thì do nhiều bạn nhập nên có lúc dữ liệu không đồng nhất ạ. Sau này em có thống nhất lại nhưng đôi lúc vẫn gặp tình trạng như trên ạ. Em sẽ tìm hiểu và học thêm những khóa ở trên ạ. Em cảm ơn Thầy nhiều ạ.
 
Upvote 0
Flash Fill 1 triệu dòng cỡ hơn 1 nửa cái nháy mắt.

Dạ, em cảm ơn các anh/chị đã giúp đỡ em giải quyết những khó khăn của em ở trên ạ. Sau khi em làm với dữ liệu của mình thì em vướng vấn đề nữa là: Nội dung có tên và Chứng minh thì sẽ tách thành cột tên và cột Chứng minh ạ. Còn nội dung chỉ có cột tên thì chỉ điền vào cột tên, cột Chứng minh để trống ạ. Em có dùng Flash Fill thì bị vướng ở cột chỉ có tên ạ. Em có mô tả trong file ạ. Anh/chị xem giúp em ạ. Em cảm ơn anh/chị ạ.
 

File đính kèm

  • TACH.xls
    38.5 KB · Đọc: 9
Upvote 0
Kính gửi anh/chị trên diễn đàn,

Em đang bị vướng về vấn đề tách chuỗi ạ. Em muốn tách tên và chứng minh nhân dân từ cột A ạ. Em có mô tả trong file đính kèm. Anh/chị xem giúp em với ạ. Em cảm ơn ạ.
sau khi so sánh từng câu chử. có thể đoán là thành viên này 80%. do bị khóa nick
hiénlinh197
là 1 nhé mọi người. Khóa ních kia thì nó tạo nick này. Vì nó đang muốn tách đoạn tin nhắn đánh đề đó. cẩn thận
Bài đã được tự động gộp:

Quản lý dữ klieeuj chừng này thì đi học một khoá quản lý đi.
Điẻn hình là học cách quản lý csdl. Nếu vẫn còn dùng Excel thì cần học PowerQuery và Powerpivot.

Cốt kiếc này nọ chỉ là đắp vá tạm thời.
không phải. Khi người ta đánh đề người ta nhắn tin kiểu nội dung là vậy. bây giờ phải nhờ Excel tách ra
 
Upvote 0
Dạ, em cám ơn anh trước.
Thử lại code sau:

Mã:
Sub TachDuLieu()
    Dim xCell As Range: Dim Vung As Object
    Set Vung = Range("A2", Range("A6000").End(xlUp))
    For Each xCell In Vung
        xCell.Offset(, 1).Value = Replace(Replace(Replace(Split(xCell.Value, ":")(0), "CCCD", ""), "CMND", ""), ",", "")
        xCell.Offset(, 2).Value = "'" & Split(xCell.Value, ":")(1)
    Next xCell
End Sub
 
Upvote 0
Web KT
Back
Top Bottom