Muốn tách ít ra phải có một quy luật nào chứ kiểu này kêu tôi mò và lựa bằng mắt bình thường cũng không biết đâu mà tách.
Quy luật tách là:
Bạn xem File
Làm sao biết được tên sản phẩm đến đâu sẽ hết mà lấy. Còn nếu tên nhà cung cấp ở giữa làm sao biết tên có mấy từ mà tách. Nói chung khó hình dung và biết được tên như thế nào, hoặc ít nhất cũng phải có danh sách như #4.
tên sản phẩm bắt đầu sau dòng Tillcode(dòng này gồm có 12, 13 số )
Thật tình tôi chưa tìm ra được quy luật để viết hàm hay code, mà #4 đã đáp ứng được yêu cầu của bạn chưa? Nếu chưa thì đợi thành viên khác hiểu mà giúp cho bạn nhé.
Hình như là vầy thì phải
Giải thích sao vòng vo tam quốc quá đi, anh chừa thêm 2 dòng để còn sử dụng cho nội dung và tiêu đề (có khi cần đến).
Có thể còn sót một số dòng
Sub Tach_NB()
Dim sArr(), Res(), S As Variant, dArr As Variant, Dic As Object
Dim i As Long, j As Long, sR As Long, n As Long
Dim tmp As String
sArr = Range("A1", Range("A65500").End(xlUp)).Value
ReDim Res(1 To UBound(sArr), 1 To 1)
Set Dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(sArr)
S = Split(Application.Trim(sArr(i, 1)), " ")
sR = UBound(S)
For j = 1 To sR
If isNum(S(j)) And j < sR Then
tmp = ""
For n = j + 1 To sR
If Not isNum(S(n)) Then tmp = tmp & " " & S(n) Else Exit For
Next n
If Len(tmp) Then
tmp = Mid(tmp, 2, Len(tmp) - 1)
If Not Dic.exists(tmp) Then Dic.Add (tmp), ""
Res(i, 1) = tmp
End If
Exit For
End If
Next j
Next i
dArr = Dic.keys
For i = 1 To UBound(sArr)
If Res(i, 1) = "" Then
tmp = Application.Trim(sArr(i, 1))
For j = 0 To UBound(dArr)
If InStr(tmp, dArr(j)) Then Res(i, 1) = dArr(j): Exit For
Next j
End If
Next i
Range("B1").Resize(UBound(sArr)) = Res
End Sub
Private Function isNum(ByVal tmp As String) As Boolean
Dim i As Byte
Const So = "(0123456789"
For i = 1 To Len(tmp)
If InStr(So, Mid(tmp, i, 1)) Then isNum = True: Exit Function
Next i
End FunctionÁi dà, phức tạp ghê, bác HieuCD ơi!
Do dữ liệu lung tung, code phải nhảy tưng tưng theo
Nếu có danh mục nhà cung cấp thì tra cũng không dễ dàng gì đâu. Chủ yêu là do lúc nhập liệu không chuẩn: Lúc có dấu chấm, lúc có dấu phẩy, lúc thì liền, lúc có 1 khoảng trắng, lúc có 2 khoảng trắng.Do dữ liệu lung tung, code phải nhảy tưng tưng theo
Nếu có danh sách nhà cung cấp thì dùng công thức hay code đều dể
Góp thêm cách dùng code:
Function tach(rng As Range)
Dim cell As Range
With CreateObject("vbscript.regexp")
.Pattern = "^.*[\d\.]+(ml|l|g|mg)([^\d\(]+).*$": .ignorecase = True ''[\d\.]+?
If .test(rng) Then
tach = .Replace(rng, "$2")
Else
For Each cell In Range(Cells(1, ActiveCell.Column), Cells(rng.Row - 1, ActiveCell.Column))
If InStr(1, rng, cell) Then tach = cell: Exit Function
Next
End If
End With
End FunctionTôi rất ngưỡng mộ bạn với thể loại vbscript.regexp, với cách đặt điều kiện .Pattern
Regex (VBA) và công thức mảng (WS) dựa vào một vài khái niệm căn bản và từ đó suy ra nhiều thiên biến vạn hoá, rất thích hợp cho những người có sử thích thử thách toán học.
Dùng vbscript.regexp quá đỉnh, nhìn code không biết gì luôn
Tôi viết lại:Dùng vbscript.regexp quá đỉnh, nhìn code không biết gì luôn
Còn 1 khả năng bạn xử luôn cho đẹp
Sub tach()
Dim cell As Range, cell1 As Range, rng As Range, arr, result, darr
arr = Range([a1], Cells(Rows.Count, 1).End(xlUp))
ReDim result(1 To UBound(arr), 1 To 1)
With CreateObject("vbscript.regexp")
.Pattern = "^.*[\d\.]+(ml|l|g|mg)([^\d\(]+).*$": .ignorecase = True
For i = 1 To UBound(arr)
If .test(arr(i, 1)) Then result(i, 1) = .Replace(arr(i, 1), "$2")
Next
[B1].Resize(UBound(result), 1) = result
Set rng = Range([B1], Cells(Rows.Count, 1).End(xlUp).Offset(, 1))
For Each cell In rng
If cell = "" Then
For Each cell1 In rng
If cell1 <> "" And InStr(1, cell.End(xlToLeft), cell1) Then cell = cell1: Exit For
Next
End If
Next
End With
End Sub
Cho em muốn hỏi anh là có thể tạo 1 Function Tổng quát dùng vớiDùng vbscript.regexp quá đỉnh, nhìn code không biết gì luôn
Còn 1 khả năng bạn xử luôn cho đẹp
Bạn hỏi nhầm người rồi, vbscript.regexp có các tham số quá nhức đầu nên mình không bao giờ đụng tới
@excel_lv1.5 có thể hướng dẫn cách em tạo ra function dạng này được không ạ ! Em cảm ơn anh Ạ
Không biết làm được không nhưng bạn đưa file ví dụ lên đi bạn , tất cả trường hợp tổng quát luôn nhe!!
Em gửi anh 1 số trường hợp tổng quát như thế này và kết quả mong muốn ! Mong sự giúp đỡ của anh !
Bạn dùng code này thử xem:
Function tach(str As String, n As Long)
With CreateObject("vbscript.regexp")
.Pattern = "([^\#\&\\\s]+)[\#\&\\]+([^\#\&\\\s]+).*,(.*)"
If .test(str) Then
Select Case n
Case 1
tach = .Execute(str)(0).submatches(1)
Case 2
tach = .Execute(str)(0).submatches(0)
Case 3
tach = .Execute(str)(0).submatches(2)
End Select
Else
.Pattern = "\b(\d[\d\s\,]+)\b\D+\b((\d{1,2}/)?\d{1,2}\/\d{4})\b"
Select Case n
Case 1
tach = .Execute(str)(0).submatches(0)
Case 2
tach = .Execute(str)(0).submatches(1)
End Select
End If
End With
End FunctionDạ vâng em cảm ơn anh ạ ! Hàm này có thể làm thành kiểu Tach(A1,"&") ra kết quả như trường hợp 1 hay đối với trường hợp giữa 2 kí tự đặc biệt .. được không Anh giống kiểu Ctrl + H ạ. Ngoài ra em muốn hỏi anh cách thức phân tích 1 chuỗi dạng này để em có thể vận dụng ở các bài sau ạ. EM cảm ơn anh ạ !
Bạn sữa code lại như vầy :
Function tach(str As String, n As Long, Optional demi As String = "")
With CreateObject("vbscript.regexp")
.Pattern = "([^" & demi & "\s]+)[" & demi & "]+([^" & demi & "\s]+).*,(.*)"
If .test(str) Then
Select Case n
Case 1
tach = .Execute(str)(0).submatches(1)
Case 2
tach = .Execute(str)(0).submatches(0)
Case 3
tach = .Execute(str)(0).submatches(2)
End Select
Else
.Pattern = "\b(\d[\d\s\,]+)\b\D+\b((\d{1,2}/)?\d{1,2}\/\d{4})\b"
Select Case n
Case 1
tach = .Execute(str)(0).submatches(0)
Case 2
tach = .Execute(str)(0).submatches(1)
End Select
End If
End With
End FunctionEm thử với chuỗi "Nguyễn văn A #AFF-UV Hơn" thì ra được kết quả là Value anh ạ. Ngoài ra cái chuỗi này em muốn dạng * đại điện cho 1 chuỗi kí tự và ? đại diện 1 ký tự anh ạ
.
Trường hợp này của bạn dựa vào đâu vào lấy, nó không cùng chung quy luật với chuỗi trên sao?
Trường hợp này nó chỉ lấy sau dấu # không kèm trường hợp " " Hơn anh ạ
Bạn chỉnh code như vầy:
Function tach(str As String, n As Long, Optional demi As String = "")
str = str & ","
With CreateObject("vbscript.regexp")
.Pattern = "([^" & demi & "\s]+)(\s*)[" & demi & "]+(\s*)([^" & demi & "\s]+)"
If .test(str) Then
Select Case n
Case 1
If Len(.Execute(str)(0).submatches(2)) = 0 Then tach = .Execute(str)(0).submatches(3)
Case 2
If Len(.Execute(str)(0).submatches(1)) = 0 Then tach = .Execute(str)(0).submatches(0)
Case 3
.Pattern = ".*,([^,]+)"
If .test(str) Then tach = .Execute(str)(0).submatches(0)
End Select
Else
.Pattern = "\b(\d[\d\s\,]+)\b\D+\b((\d{1,2}/)?\d{1,2}\/\d{4})\b"
If .test(str) Then
Select Case n
Case 1
tach = .Execute(str)(0).submatches(0)
Case 2
tach = .Execute(str)(0).submatches(1)
End Select
End If
End If
End With
End FunctionNgoài ra anh cho em hỏi với Cách thức để phân tích chuỗi này để các trường hợp sau em nghiên cứu và thực hiện với ! Mỗi lần dùng công thức này em lại phải xác định được chuỗi pattern nhưng chưa biết phân tách kiểu gì cho ổn cho nên ví vụ công thức này mà em muốn lấy số trong chuỗi thì em để ở ngoài là :LayTextDk(E6,"[^0-9]","",FALSE). Anh có thể giúp em phần này được không ạ !
Bạn đọc mấy bài này thử xem:
Thank anh ạ ! Để em nghiên cứu thêm ạ
bạn dùng công cụ Flash fill ấy, lên google để xem cách sử dụng
