Nhờ mọi người giúp mình Sửa đoạn code sau để được kết quả như hình

N

n3ono1

Yêu THVBA
Link file test của em đây ạ :

Bạn cần đăng nhập để thấy link

Em có 1 đoạn code dưới đây :


Mã: 
Sub SplitAll()
    Dim xRg As Range
    Dim xRg1 As Range
    Dim xCell As Range
    Dim I As Long, j As Long, cnt As Long   'tuhocvba.net
    Dim xAddress As String
    Dim xUpdate As Boolean
    Dim xRet As Variant
 
    Range("A11:A40").ClearContents
    Range("B11:B40").ClearContents
 
    Dim s           As String, kqtemp As String, gttemp As String 'tuhocvba.net
    Const phantach  As String = ",.-" 'tuhocvba.net
    On Error Resume Next
    xAddress = Application.ActiveWindow.RangeSelection.Address
    Set xRg = ActiveWorkbook.ActiveSheet.Range("A3")
    Set xRg1 = ActiveWorkbook.ActiveSheet.Range("A11")


    If xRg Is Nothing Then Exit Sub
        If xRg.Columns.Count > 1 Then
            MsgBox "You can't select multiple columns", , "Hoc Excel Online"
            Exit Sub
            End If
'            Set xRg1 = Application.InputBox("Chon Hang Cot Dich:", "Kutools for Excel", , , , , , 8) 'Khong can thiet vi da co dinh I6
'            Set xRg1 = xRg1.Range("A1")
            If xRg1 Is Nothing Then Exit Sub
                xUpdate = Application.ScreenUpdating
                Application.ScreenUpdating = False
                For Each xCell In xRg
                    s = xCell.Value
                    cnt = -1
                    If s = "" Then
                        ReDim xRet(0 To 0)
                        xRet(0) = s
                    Else
                        kqtemp = ""
                        gttemp = ""
                        For j = 1 To Len(s) Step 1
                            kqtemp = Mid(s, j, 1)
                            If InStr(1, phantach, kqtemp, vbTextCompare) = 0 Then
                                If j = Len(s) Then
                                    cnt = cnt + 1
                                    If cnt = 0 Then
                                        ReDim xRet(0 To cnt)
                                    Else
                                        ReDim Preserve xRet(0 To cnt)
                                    End If
                                    gttemp = gttemp & kqtemp
                                    xRet(cnt) = gttemp
                                    Exit For
                                End If
                                gttemp = gttemp & kqtemp
                            Else
                           
                                cnt = cnt + 1
                                If cnt = 0 Then
                                    ReDim xRet(0 To cnt)
                                Else
                                    ReDim Preserve xRet(0 To cnt)
                                End If
                                xRet(cnt) = gttemp
                                gttemp = "" 'Reset
                            End If
                        Next j
                    End If
               
                    xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0)) = Application.WorksheetFunction.Transpose(xRet)
                    I = I + UBound(xRet, 1) + 1
                Next
    Application.ScreenUpdating = xUpdate
 
End Sub
Hình ảnh khi chạy test như sau :

Bạn cần đăng nhập để thấy hình ảnh


Code hiện giờ em mới xử lý được đó là tách tên mã hàng thành từng cột.

Em muốn xử lý những số sau chữ "x" được tự động nhập hết sang số lượng hàng hóa.

Em muốn xử lý thành kết quả như hình dưới đây,mong mọi người giúp em.

Bạn cần đăng nhập để thấy hình ảnh



Em xin chân thành cảm ơn sự giúp đỡ của mọi người :)
 
D

Deleted member 208

Guest
Mình không hiểu tại sao số lượng hàng hóa của AOS8979 lại là 30 ?
Khi làm ra macro tách x để lấy lượng hàng hóa thì được:
Bạn cần đăng nhập để thấy hình ảnh

Sau đó ngẫm nghĩ một hồi, có lẽ là bạn muốn:
Bạn cần đăng nhập để thấy hình ảnh

Vậy code là:
Mã: 
Sub tuhocvba0322()
    Dim arr     As Variant, kqrr    As Variant
    Dim i       As Long, cnt        As Long, vt As Long
    Dim rend    As Long
    Dim s       As String   'Cells A3
    Dim temp    As String, temp1    As String, temp2   As String
    Const c1    As Integer = 1 'Cot A
    Const c2    As Integer = 2 'Cot B
    Const r1    As Long = 10 'Dong tieu de
    Const phantach0 As String = ","
    Const phantach1 As String = "x"
    
    'Xac dinh dong cuoi cua bang du lieu
    s = ActiveWorkbook.ActiveSheet.Cells(3, 1)
    If s = "" Then
        MsgBox "Hay nhap du lieu vao o A3"
        Exit Sub
    End If
    rend = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, c1).End(xlUp).Row
    If rend < r1 Then
        MsgBox "Xem lai form du lieu khong co dong tieu de, dong tieu de phai la " & r1
    ElseIf rend = r1 Then
    Else
        'Xoa vung du lieu cu
        ActiveWorkbook.ActiveSheet.Range(Cells(r1 + 1, c1), Cells(rend, c2)).ClearContents
    End If
    '==================PHAN TICH CELLS A3=================
    'INPUT: AOS8979,AOS7535,AOS3135x70
    'OUTPUT: Tac ra thanh cac phan tu:
    'arr(0) = AOS8979
    'arr(1) = AOS7535
    'arr(2) = AOS3135x70
    cnt = 0
    arr = Split(s, phantach0)
    For i = LBound(arr) To UBound(arr) Step 1
        temp = CStr(arr(i))
        temp1 = "" 'Reset
        temp2 = "" 'Reset
        vt = InStr(1, temp, phantach1, vbTextCompare)
        If vt = 0 Then
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp
            kqrr(2, cnt) = ""
        Else
            temp1 = Left(temp, vt - 1)
            temp2 = Right(temp, Len(temp) - vt)
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp1
            kqrr(2, cnt) = temp2
        End If
        
    Next i
    
    '==================GHI KET QUA=================
    If cnt = 0 Then Exit Sub
    'Ghi chen ket qua vao cac o trong
    temp = ""
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For i = cnt To 1 Step -1
        If CStr(kqrr(2, i)) <> "" Then
            temp = CStr(kqrr(2, i))
        Else
            kqrr(2, i) = temp
        End If
        
    Next i
    For i = 1 To cnt Step 1
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c1) = kqrr(1, i)
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c2) = kqrr(2, i)
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
 
N

n3ono1

Yêu THVBA
sieutocviet3 nói:
Mình không hiểu tại sao số lượng hàng hóa của AOS8979 lại là 30 ?
Khi làm ra macro tách x để lấy lượng hàng hóa thì được:
Bạn cần đăng nhập để thấy hình ảnh

Sau đó ngẫm nghĩ một hồi, có lẽ là bạn muốn:
Bạn cần đăng nhập để thấy hình ảnh

Vậy code là:
Mã: 
Sub tuhocvba0322()
    Dim arr     As Variant, kqrr    As Variant
    Dim i       As Long, cnt        As Long, vt As Long
    Dim rend    As Long
    Dim s       As String   'Cells A3
    Dim temp    As String, temp1    As String, temp2   As String
    Const c1    As Integer = 1 'Cot A
    Const c2    As Integer = 2 'Cot B
    Const r1    As Long = 10 'Dong tieu de
    Const phantach0 As String = ","
    Const phantach1 As String = "x"
   
    'Xac dinh dong cuoi cua bang du lieu
    s = ActiveWorkbook.ActiveSheet.Cells(3, 1)
    If s = "" Then
        MsgBox "Hay nhap du lieu vao o A3"
        Exit Sub
    End If
    rend = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, c1).End(xlUp).Row
    If rend < r1 Then
        MsgBox "Xem lai form du lieu khong co dong tieu de, dong tieu de phai la " & r1
    ElseIf rend = r1 Then
    Else
        'Xoa vung du lieu cu
        ActiveWorkbook.ActiveSheet.Range(Cells(r1 + 1, c1), Cells(rend, c2)).ClearContents
    End If
    '==================PHAN TICH CELLS A3=================
    'INPUT: AOS8979,AOS7535,AOS3135x70
    'OUTPUT: Tac ra thanh cac phan tu:
    'arr(0) = AOS8979
    'arr(1) = AOS7535
    'arr(2) = AOS3135x70
    cnt = 0
    arr = Split(s, phantach0)
    For i = LBound(arr) To UBound(arr) Step 1
        temp = CStr(arr(i))
        temp1 = "" 'Reset
        temp2 = "" 'Reset
        vt = InStr(1, temp, phantach1, vbTextCompare)
        If vt = 0 Then
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp
            kqrr(2, cnt) = ""
        Else
            temp1 = Left(temp, vt - 1)
            temp2 = Right(temp, Len(temp) - vt)
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp1
            kqrr(2, cnt) = temp2
        End If
       
    Next i
   
    '==================GHI KET QUA=================
    If cnt = 0 Then Exit Sub
    'Ghi chen ket qua vao cac o trong
    temp = ""
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For i = cnt To 1 Step -1
        If CStr(kqrr(2, i)) <> "" Then
            temp = CStr(kqrr(2, i))
        Else
            kqrr(2, i) = temp
        End If
       
    Next i
    For i = 1 To cnt Step 1
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c1) = kqrr(1, i)
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c2) = kqrr(2, i)
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
End Sub
Nhấn để mở rộng...
Em cảm ơn bác rất nhiều ạ.... Bác cho em hỏi,nếu giờ em muốn thay dấu "," thành nhiều dấu cùng 1 lúc thì em phải làm thế nào ạ.
Ví dụ văn bản là : AoCoc,QuanJeanx20.Sandal.Giayx30
Thì em phải làm thế nào ạ. Em vẫn muốn tách như vậy thôi ạ
 
B

bvtvba

Guest
Tùy ý chỉnh dòng code số 10 theo ý bạn. Trong code này tôi để phân tách là , hoặc . theo như bạn mô tả:
Mã: 
Sub bvtvba()
    Dim arr     As Variant, kqrr    As Variant
    Dim i       As Long, cnt        As Long, vt As Long
    Dim rend    As Long
    Dim s       As String   'Cells A3
    Dim temp    As String, temp1    As String, temp2   As String
    Const c1    As Integer = 1 'Cot A
    Const c2    As Integer = 2 'Cot B
    Const r1    As Long = 10 'Dong tieu de
    Const phantach0 As String = ",."
    Const phantach1 As String = "x"
    
    'Xac dinh dong cuoi cua bang du lieu
    s = ActiveWorkbook.ActiveSheet.Cells(3, 1)
    If s = "" Then
        MsgBox "Hay nhap du lieu vao o A3"
        Exit Sub
    End If
    rend = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, c1).End(xlUp).Row
    If rend < r1 Then
        MsgBox "Xem lai form du lieu khong co dong tieu de, dong tieu de phai la " & r1
    ElseIf rend = r1 Then
    Else
        'Xoa vung du lieu cu
        ActiveWorkbook.ActiveSheet.Range(Cells(r1 + 1, c1), Cells(rend, c2)).ClearContents
    End If
    '==================PHAN TICH CELLS A3=================
    'INPUT: AOS8979,AOS7535,AOS3135x70
    'OUTPUT: Tac ra thanh cac phan tu:
    'arr(0) = AOS8979
    'arr(1) = AOS7535
    'arr(2) = AOS3135x70
    cnt = 0
    arr = tachkytu(s, phantach0)
    For i = LBound(arr) To UBound(arr) Step 1
        temp = CStr(arr(i))
        temp1 = "" 'Reset
        temp2 = "" 'Reset
        vt = InStr(1, temp, phantach1, vbTextCompare)
        If vt = 0 Then
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp
            kqrr(2, cnt) = ""
        Else
            temp1 = Left(temp, vt - 1)
            temp2 = Right(temp, Len(temp) - vt)
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp1
            kqrr(2, cnt) = temp2
        End If
        
    Next i
    
    '==================GHI KET QUA=================
    If cnt = 0 Then Exit Sub
    'Ghi chen ket qua vao cac o trong
    temp = ""
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For i = cnt To 1 Step -1
        If CStr(kqrr(2, i)) <> "" Then
            temp = CStr(kqrr(2, i))
        Else
            kqrr(2, i) = temp
        End If
        
    Next i
    For i = 1 To cnt Step 1
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c1) = kqrr(1, i)
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c2) = kqrr(2, i)
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
'INPUT: s = AoCoc,QuanJeanx20.Sandal.Giayx30
'INPUT: phantach0 = ",."
'OUTPUT:
'AoCoc
'QuanJeanx20.
'Sandal
'Giayx30
Function tachkytu(ByVal s As String, ByVal phantach0 As String) As Variant
    Dim i       As Long, j As Long, cnt As Long, vt As Long
    Dim xRet    As Variant
    Dim kqtemp  As String, gttemp As String
    
    cnt = -1
    If s = "" Then
            ReDim xRet(0 To 0)
            xRet(0) = s
    Else
            kqtemp = ""
            gttemp = ""
            For j = 1 To Len(s) Step 1
                kqtemp = Mid(s, j, 1)
                If InStr(1, phantach0, kqtemp, vbTextCompare) = 0 Then
                    If j = Len(s) Then
                            cnt = cnt + 1
                            If cnt = 0 Then
                                ReDim xRet(0 To cnt)
                            Else
                                ReDim Preserve xRet(0 To cnt)
                            End If
                                gttemp = gttemp & kqtemp
                                xRet(cnt) = gttemp
                                Exit For
                    End If
                                gttemp = gttemp & kqtemp
                Else
                              
                    cnt = cnt + 1
                    If cnt = 0 Then
                        ReDim xRet(0 To cnt)
                    Else
                        ReDim Preserve xRet(0 To cnt)
                    End If
                    xRet(cnt) = gttemp
                    gttemp = "" 'Reset
                End If
            Next j
    End If
    tachkytu = xRet
End Function
Kết quả:
Bạn cần đăng nhập để thấy hình ảnh
 
N

n3ono1

Yêu THVBA
bvtvba nói:
Tùy ý chỉnh dòng code số 10 theo ý bạn. Trong code này tôi để phân tách là , hoặc . theo như bạn mô tả:
Mã: 
Sub bvtvba()
    Dim arr     As Variant, kqrr    As Variant
    Dim i       As Long, cnt        As Long, vt As Long
    Dim rend    As Long
    Dim s       As String   'Cells A3
    Dim temp    As String, temp1    As String, temp2   As String
    Const c1    As Integer = 1 'Cot A
    Const c2    As Integer = 2 'Cot B
    Const r1    As Long = 10 'Dong tieu de
    Const phantach0 As String = ",."
    Const phantach1 As String = "x"
   
    'Xac dinh dong cuoi cua bang du lieu
    s = ActiveWorkbook.ActiveSheet.Cells(3, 1)
    If s = "" Then
        MsgBox "Hay nhap du lieu vao o A3"
        Exit Sub
    End If
    rend = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, c1).End(xlUp).Row
    If rend < r1 Then
        MsgBox "Xem lai form du lieu khong co dong tieu de, dong tieu de phai la " & r1
    ElseIf rend = r1 Then
    Else
        'Xoa vung du lieu cu
        ActiveWorkbook.ActiveSheet.Range(Cells(r1 + 1, c1), Cells(rend, c2)).ClearContents
    End If
    '==================PHAN TICH CELLS A3=================
    'INPUT: AOS8979,AOS7535,AOS3135x70
    'OUTPUT: Tac ra thanh cac phan tu:
    'arr(0) = AOS8979
    'arr(1) = AOS7535
    'arr(2) = AOS3135x70
    cnt = 0
    arr = tachkytu(s, phantach0)
    For i = LBound(arr) To UBound(arr) Step 1
        temp = CStr(arr(i))
        temp1 = "" 'Reset
        temp2 = "" 'Reset
        vt = InStr(1, temp, phantach1, vbTextCompare)
        If vt = 0 Then
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp
            kqrr(2, cnt) = ""
        Else
            temp1 = Left(temp, vt - 1)
            temp2 = Right(temp, Len(temp) - vt)
            cnt = cnt + 1
            If cnt = 1 Then
                ReDim kqrr(1 To 2, 1 To cnt)
            Else
                ReDim Preserve kqrr(1 To 2, 1 To cnt)
            End If
            kqrr(1, cnt) = temp1
            kqrr(2, cnt) = temp2
        End If
       
    Next i
   
    '==================GHI KET QUA=================
    If cnt = 0 Then Exit Sub
    'Ghi chen ket qua vao cac o trong
    temp = ""
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For i = cnt To 1 Step -1
        If CStr(kqrr(2, i)) <> "" Then
            temp = CStr(kqrr(2, i))
        Else
            kqrr(2, i) = temp
        End If
       
    Next i
    For i = 1 To cnt Step 1
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c1) = kqrr(1, i)
        ActiveWorkbook.ActiveSheet.Cells(r1 + i, c2) = kqrr(2, i)
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
End Sub
'INPUT: s = AoCoc,QuanJeanx20.Sandal.Giayx30
'INPUT: phantach0 = ",."
'OUTPUT:
'AoCoc
'QuanJeanx20.
'Sandal
'Giayx30
Function tachkytu(ByVal s As String, ByVal phantach0 As String) As Variant
    Dim i       As Long, j As Long, cnt As Long, vt As Long
    Dim xRet    As Variant
    Dim kqtemp  As String, gttemp As String
   
    cnt = -1
    If s = "" Then
            ReDim xRet(0 To 0)
            xRet(0) = s
    Else
            kqtemp = ""
            gttemp = ""
            For j = 1 To Len(s) Step 1
                kqtemp = Mid(s, j, 1)
                If InStr(1, phantach0, kqtemp, vbTextCompare) = 0 Then
                    If j = Len(s) Then
                            cnt = cnt + 1
                            If cnt = 0 Then
                                ReDim xRet(0 To cnt)
                            Else
                                ReDim Preserve xRet(0 To cnt)
                            End If
                                gttemp = gttemp & kqtemp
                                xRet(cnt) = gttemp
                                Exit For
                    End If
                                gttemp = gttemp & kqtemp
                Else
                             
                    cnt = cnt + 1
                    If cnt = 0 Then
                        ReDim xRet(0 To cnt)
                    Else
                        ReDim Preserve xRet(0 To cnt)
                    End If
                    xRet(cnt) = gttemp
                    gttemp = "" 'Reset
                End If
            Next j
    End If
    tachkytu = xRet
End Function
Kết quả:
Bạn cần đăng nhập để thấy hình ảnh
Nhấn để mở rộng...
Em cảm ơn bác nhiều ạ,em làm được rồi ạ :)
 
B

bvtvba

Guest
Ừ không có gì. Tôi cũng học hỏi và nhận được giúp đỡ của anh chị trên diễn đàn. Có chút kiến thức ít ỏi giúp được bạn là tôi vui rồi. Mỗi người xúm vào một tay để hình thành nên cộng đồng cởi mở tự học.
Trong code trên thì:
Function tachkytu
để tách AoCoc,QuanJeanx20.Sandal.Giayx30 thành: AoCoc,QuanJeanx20,Sandal,Giayx30 giống yêu cầu lần trước của bạn ở đây:
Bạn cần đăng nhập để thấy link

Bạn cần đăng nhập để thấy link
của sieutocviet3. Tôi nghĩ nếu bạn trình bày mạch lạc rõ ý đồ thì sẽ chỉ cần một topic hỗ trợ là đủ. Nhưng không sao, trình bày cho người khác hiểu là việc khó, dần dần chúng mình sẽ cũng nhau trưởng thành hơn nhờ hướng dẫn và kỷ luật của các anh chị trong BQT diễn đàn.
 
Bạn phải đăng nhập hoặc đăng ký để bình luận.
Top