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
