[Cần giúp đỡ] Sửa code tách chuỗi kí tự khi update thêm cột dữ liệu

Liên hệ QC
Datcdt2k9

Datcdt2k9

Thành viên hoạt động
Tham gia
27/12/19
Bài viết
109
Được thích
11
Em chào mọi người
Code trong file của em trước có nhờ 1 anh trên diễn đàn viết cho, mà giờ dữ liệu của em (Chuỗi kí tự) có phát sinh thêm nên cần tách dữ liệu đó ra 2 cột mới, code cũ tách không còn đúng nữa.
Nhờ mọi người giúp em sửa code tách dữ liệu như trong file đính kèm bên dưới
1. Ảnh thứ 1 là "sheet Nhaplieu "để em update dữu liệu hàng ngày => Run => Ảnh 2
2. Ảnh 2 "Sheet K4" là kết quả em cần tách chuỗi kí tự bên sheet Nhaplieu. Dấu khoanh đỏ là dữ liệu phát sinh thêm trong chuỗi kí tự cần tách của em
Em xin cảm ơn


1611671182812.png



1611671060096.png
 

File đính kèm

  • TEST FILL DOWN_V003_25_01.xlsm
    44.2 KB · Đọc: 17
  • 1611671086154.png
    1611671086154.png
    188.8 KB · Đọc: 25
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Datcdt2k9 đã viết:
Em chào mọi người
Code trong file của em trước có nhờ 1 anh trên diễn đàn viết cho, mà giờ dữ liệu của em (Chuỗi kí tự) có phát sinh thêm nên cần tách dữ liệu đó ra 2 cột mới, code cũ tách không còn đúng nữa.
Nhờ mọi người giúp em sửa code tách dữ liệu như trong file đính kèm bên dưới
1. Ảnh thứ 1 là "sheet Nhaplieu "để em update dữu liệu hàng ngày => Run => Ảnh 2
2. Ảnh 2 "Sheet K4" là kết quả em cần tách chuỗi kí tự bên sheet Nhaplieu. Dấu khoanh đỏ là dữ liệu phát sinh thêm trong chuỗi kí tự cần tách của em
Em xin cảm ơn


View attachment 253557



View attachment 253555
Nhấp chuột vào đây để mở rộng...
Bạn đang nói xử lý chỗ nào đấy nhỉ? Mỗi cột K thôi hay sao
 
Upvote 0
Em update thêm cột J Và K anh ạ
Nhattanktnn đã viết:
Bạn đang nói xử lý chỗ nào đấy nhỉ? Mỗi cột K thôi hay sao
Nhấp chuột vào đây để mở rộng...
Bài đã được tự động gộp:

Nhattanktnn đã viết:
Bạn đang nói xử lý chỗ nào đấy nhỉ? Mỗi cột K thôi hay sao
Nhấp chuột vào đây để mở rộng...
Em update thêm cột J và K anh ạ, do chuỗi kí tự của em update thêm dữ liệu của 2 cột này
 
Upvote 0
Tôi chỉ thêm vài dòng code trong sub cũ để lấy được thông tin thêm cho 2 cột J và K, còn không hiểu vì sao kết quả cũ lại thừa dòng (hồi khác xem lại)
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        dArr(K, 1) = K + oldSTT
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
      
    Next
Next
With Ws
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Activate
End With
End Sub
 
Upvote 0
Maika8008 đã viết:
Tôi chỉ thêm vài dòng code trong sub cũ để lấy được thông tin thêm cho 2 cột J và K, còn không hiểu vì sao kết quả cũ lại thừa dòng (hồi khác xem lại)
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        dArr(K, 1) = K + oldSTT
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
     
    Next
Next
With Ws
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Activate
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em test code trên thì cột type (cột F) không tách được data ra anh ạ
 
Upvote 0
Có phải bạn mong muốn kết quả là thế này không?
1611740551042.png
Tôi chỉnh sửa code tiếp để kết quả có đúng số dòng như dữ liệu nguồn:
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
'oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
'If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    K = K + 1
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
      
    Next
Next
With Ws
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Range("A2").Resize(10000, R2).ClearContents
.Range("A2").Resize(K, R2) = dArr
.Activate
End With
End Sub
 
Upvote 0
Maika8008 đã viết:
Có phải bạn mong muốn kết quả là thế này không?
View attachment 253587
Tôi chỉnh sửa code tiếp để kết quả có đúng số dòng như dữ liệu nguồn:
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
'oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
'If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    K = K + 1
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
 
    Next
Next
With Ws
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Range("A2").Resize(10000, R2).ClearContents
.Range("A2").Resize(K, R2) = dArr
.Activate
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh đã giúp, em xin giải thích lại về mục đích sheet Nhaplieu là để update dữ liệu nguồn hàng ngày => tách data vào các sheet mong muốn,anh giúp em giữ nguyên nguyên lý hoạt động giống code ban đầu, và tách kết quả như hình em khoanh đỏ, code của anh em test khi xóa data cũ, dán data mới vào=> Run code => thì data bên sheet K4 cũng biết mất luôn, sheet nhaplieu sau khi update xong em sẽ xóa đi để ngày hôm sau update data mới vào
=> sheet Nhaplieu em chỉ dùng để update data, sau khi update xong về các sheet mong muốn, em sẽ xóa đi. cảm ơn anh
 
Lần chỉnh sửa cuối:
Upvote 0
Maika8008 đã viết:
Có phải bạn mong muốn kết quả là thế này không?
View attachment 253587
Tôi chỉnh sửa code tiếp để kết quả có đúng số dòng như dữ liệu nguồn:
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
'oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
'If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    K = K + 1
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
 
    Next
Next
With Ws
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Range("A2").Resize(10000, R2).ClearContents
.Range("A2").Resize(K, R2) = dArr
.Activate
End With
End Sub
Nhấp chuột vào đây để mở rộng...

Maika8008 đã viết:
Có phải bạn mong muốn kết quả là thế này không?
View attachment 253587
Tôi chỉnh sửa code tiếp để kết quả có đúng số dòng như dữ liệu nguồn:
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
'oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
'If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    K = K + 1
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    If InStr(1, sType, "X", 1) = 0 Then sType = ""
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        dArr(K, 1) = K
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = sType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
  
    Next
Next
With Ws
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
'.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Range("A2").Resize(10000, R2).ClearContents
.Range("A2").Resize(K, R2) = dArr
.Activate
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em xin update lại file, trong file bên sheet K4 là Ket quả em mong muốn để code tách ra ạ.Cột Dải được tách ra thành cột CTD nên kết quả số dòng sẽ nhiều hơn dữ liệu nguồn. em cảm ơn
1611751672046.png
dữ liệu nguồn
 

File đính kèm

  • TEST FILL DOWN_V003_25_01.xlsm
    44.4 KB · Đọc: 5
Lần chỉnh sửa cuối:
Upvote 0
Datcdt2k9 đã viết:
Em xin update lại file, trong file bên sheet K4 là Ket quả em mong muốn để code tách ra ạ.Cột Dải được tách ra thành cột CTD nên kết quả số dòng sẽ nhiều hơn dữ liệu nguồn. em cảm ơn
View attachment 253598
dữ liệu nguồn
Nhấp chuột vào đây để mở rộng...
Rồi, thử lại nhé, bạn!
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$, FType$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
    
    If InStr(1, sType, "X", 1) = 0 Then
        sType = ""
    End If
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        FType = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 4, 2)
        dArr(K, 1) = K + oldSTT
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = FType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
      
    Next
Next
With Ws
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Activate
End With
End Sub
 
Upvote 0
Maika8008 đã viết:
Rồi, thử lại nhé, bạn!
Rich (BB code): 
Sub NTKTNN_K4()
Dim sArr(), dArr(), I&, J&, K&, R&, R1&, R2&, SL(), oldSTT$
Dim Model$, PGM$, Dai$, CTD$, sType$, Side$, sChuoi$, ECN$, FType$
Dim Ws As Worksheet
Set Ws = Sheets("K4")     'Neu muon thay doi sheet gán ket qua thi sua ten sheet cho này
sArr = Sheets("NhapLieu").Range("A2:K" & Sheets("NhapLieu").Cells(Rows.Count, "C").End(xlUp).Row).Value
R = UBound(sArr, 1): R2 = UBound(sArr, 2)
ReDim SL(1 To R)
oldSTT = Ws.Cells(Rows.Count, "A").End(xlUp).Value
If Not IsNumeric(oldSTT) Then oldSTT = 0
For I = 1 To R
    sChuoi = sArr(I, 3)
   On Error Resume Next
    SL(I) = 1
    SL(I) = 1 - Evaluate(Rex(sChuoi, "\d{3}-\d{3}"))
On Error GoTo 0
    R1 = R1 + SL(I)
Next
ReDim dArr(1 To R1, 1 To R2)
For I = 1 To R
    sChuoi = sArr(I, 3)
    On Error Resume Next
    Side = Right(Rex(sChuoi, "_[A-Z]{2}(?=_)"), 1)
    On Error GoTo 0
    sType = Rex(sChuoi, "\w{2}(?=\.ZIP)")
  
    If InStr(1, sType, "X", 1) = 0 Then
        sType = ""
    End If
    Dai = Rex(sChuoi, "[A-Z0-9|-]{10,}")
    For J = 1 To SL(I)
        K = K + 1
        CTD = Rex(sChuoi, "[A-Z0-9]{10,}")
        CTD = Left(CTD, Len(CTD) - 3) & Format(Right(CTD, 3) + J - 1, "000")
        PGM = Mid(sChuoi, 2, Len(sChuoi))
        Model = Left(PGM, 7) & CTD & sType & Side
        If InStrRev(sArr(I, 3), "ECN") > 0 Then
            ECN = Mid(sArr(I, 3), InStrRev(sArr(I, 3), "ECN"), 4)
        Else
            ECN = ""
        End If
        FType = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 4, 2)
        dArr(K, 1) = K + oldSTT
        dArr(K, 2) = Model
        dArr(K, 3) = PGM
        dArr(K, 4) = Dai
        dArr(K, 5) = CTD
        dArr(K, 6) = FType
        dArr(K, 7) = Side
        dArr(K, 8) = sArr(I, 8)
        dArr(K, 9) = sArr(I, 9)
        dArr(K, 10) = Mid(sArr(I, 3), InStrRev(sArr(I, 3), ".") - 1, 1)
        dArr(K, 11) = ECN
    
    Next
Next
With Ws
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(10000, R2).ClearContents
.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(K, R2) = dArr
.Activate
End With
End Sub
Nhấp chuột vào đây để mở rộng...
em test thì thấy code tách bị lỗi 1 cột anh ạ. cột lỗi là cột D , data cột D đúng là vùng em khoanh đỏ a ạ. Tiện anh chỉnh giúp em 1 chút giá trị cột B sau khi code tách sẽ là giá trị của các cột = Left(C2,7)&E&F&G&J&K anh ạ.
1611840602524.png
 
Lần chỉnh sửa cuối:
Upvote 0
Datcdt2k9 đã viết:
em test thì thấy code tách bị lỗi 1 cột anh ạ. cột lỗi là cột D , data cột D đúng là vùng em khoanh đỏ a ạ. Tiện anh chỉnh giúp em 1 chút giá trị cột B sau khi code tách sẽ là giá trị của các cột = Left(C2,7)&E&F&G&J&K anh ạ.
View attachment 253662
Nhấp chuột vào đây để mở rộng...
Bạn có chạy nhầm code nào không chứ kết quả tôi đưa lên tại hình bài #7 vẫn đúng như bạn khoanh đỏ mà?!
 
Upvote 0
Tôi gửi file đã chỉnh cột B.

Lưu ý tôi chỉ sửa mỗi code K4 thôi dấy nhé. Các code khác bạn copy và chỉnh sửa lại địa chỉ đích.
 

File đính kèm

  • TEST FILL DOWN_V003_25_01_Datcdt2k9.xlsm
    49.3 KB · Đọc: 9
Upvote 0
Maika8008 đã viết:
Bạn có chạy nhầm code nào không chứ kết quả tôi đưa lên tại hình bài #7 vẫn đúng như bạn khoanh đỏ mà?!
Nhấp chuột vào đây để mở rộng...
Hiện tại dữ liệu em quản lý bao gồm cả data nguồn cũ và data nguồn mới nên mới phát sinh trường hợp tách sai, , anh giúp em tối ưu code trong trường hợp tổng quát nhất khi run code có thể tách cả data nguồn dạng cũ và data nguồn dạng mới để em có thể tối ưu hơn khi quản lý dữ liệu, tránh phát sinh quản lý quá nhiều sheet dữ liệu. Em đã tổng hợp tất cả các trường hợp dữ liệu có thể gặp phải trong data nguồn cũ và mới trong file đính kèm bên dưới. Em cảm ơn anh ạ

Sheet nhapLieu : Bao gồm các trường hợp data nguồn cũ và mới
1611930626095.png
Sheet K4 : Là sheet kết quả mong muốn khi run code
1611930645818.png
 

File đính kèm

  • TEST FILL DOWN_V003_EDIT_FINAL.xlsm
    35 KB · Đọc: 5
Lần chỉnh sửa cuối:
Upvote 0
Datcdt2k9 đã viết:
Hiện tại dữ liệu em quản lý bao gồm cả data nguồn cũ và data nguồn mới nên mới phát sinh trường hợp tách sai, , anh giúp em tối ưu code trong trường hợp tổng quát nhất khi run code có thể tách cả data nguồn dạng cũ và data nguồn dạng mới để em có thể tối ưu hơn khi quản lý dữ liệu, tránh phát sinh quản lý quá nhiều sheet dữ liệu. Em đã tổng hợp tất cả các trường hợp dữ liệu có thể gặp phải trong data nguồn cũ và mới trong file đính kèm bên dưới. Em cảm ơn anh ạ

Sheet nhapLieu : Bao gồm các trường hợp data nguồn cũ và mới
View attachment 253719
Sheet K4 : Là sheet kết quả mong muốn khi run code
View attachment 253720
Nhấp chuột vào đây để mở rộng...
Bạn có đưa hết dữ liệu nguồn đầy đủ và có yêu cầu nhất quán ngay từ đầu đâu? Tôi chỉ xử lý những gì bạn gọi là lỗi chứ có biết ban đầu là gì. Hay là bạn quay lại thớt cũ hỏi lại xem!
 
Upvote 0
Maika8008 đã viết:
Bạn có đưa hết dữ liệu nguồn đầy đủ và có yêu cầu nhất quán ngay từ đầu đâu? Tôi chỉ xử lý những gì bạn gọi là lỗi chứ có biết ban đầu là gì. Hay là bạn quay lại thớt cũ hỏi lại xem!
Nhấp chuột vào đây để mở rộng...



Maika8008 đã viết:
Bạn có đưa hết dữ liệu nguồn đầy đủ và có yêu cầu nhất quán ngay từ đầu đâu? Tôi chỉ xử lý những gì bạn gọi là lỗi chứ có biết ban đầu là gì. Hay là bạn quay lại thớt cũ hỏi lại xem!
Nhấp chuột vào đây để mở rộng...
Vâng, code anh viết cho em là ok hết so với ví dụ mẫu em nhờ anh viết, í em nói là em chưa đưa đầy đủ các trường hợp vào bài viết nên khi em đưa data cũ vào, phát sinh tách chưa đúng kết quả mong muốn.Anh giúp em tối ưu code để khi phát sinh cả data cũ và data mới thì code vẫn tách ok giúp em với ạ, vì data của em hiệu giờ phát sinh cả 2 trường hợp như vậy, nếu tách riêng data mới và cũ thì em cần quản lý rất nhiều sheet nên em suy nghĩ mang đầy đủ các trường hợp lên đây ( data cũ, data mới) nhờ anh giúp đỡ để em quản lý được tối ưu hơn ạ
 
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

ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
246
Đọc
13K
trannguyen197
T
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
28
Đọc
602
Tuấn Bụng Bự
Tuấn Bụng Bự
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
9
Đọc
236
ptm0412
ptm0412
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
14
Đọc
269
ptm0412
ptm0412
B
Định dạng condition formatting, đếm hỗn hợp dữ liệu merge và không merge
Trả lời
7
Đọc
117
Hoàng Tuấn 868
H
T
Tối ưu hóa hàm lấy dữ liệu từ bảng Tổng sang bảng chi tiết
Trả lời
7
Đọc
212
Hoàng Tuấn 868
H
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
6
Đọc
108
tigertiger
tigertiger
T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
8
Đọc
1K
hoangtuaotrang_hp_vn
H
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
3
Đọc
114
batista911
B
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
92
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
155
kimtanmap
kimtanmap
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
77
hoangtuaotrang_hp_vn
H
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
49
huynhnhu1234
huynhnhu1234
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
127
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
119
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
164
zarra
zarra
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
148
Đọc
95K
leminhksvl
L
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Cảm ơn
    • Thích
Trả lời
5
Đọc
296
anhdepjai
A
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
17
Đọc
20K
DeTong
D
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
306
cantl
C
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

Back
Top Bottom