Mọi người giúp em sửa code tách văn bản cách nhau bởi các dấu "." dấu ","

N

n3ono1

Yêu THVBA
Em có thử test 1 đoạn code trong file dưới link em gửi sau đây :

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


Code như sau ạ :

Mã: 
Sub SplitAll()
    Dim xRg As Range
    Dim xRg1 As Range
    Dim xCell As Range
    Dim I As Long
    Dim xAddress As String
    Dim xUpdate As Boolean
    Dim xRet As Variant
    On Error Resume Next
    xAddress = Application.ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Chon Hang Cot Van Ban Can Tach", "Kutools for Excel", xAddress, , , , , 8)
    Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    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 Tin Tach:", "Kutools for Excel", , , , , , 8)
            Set xRg1 = xRg1.Range("A1")
            If xRg1 Is Nothing Then Exit Sub
                xUpdate = Application.ScreenUpdating
                Application.ScreenUpdating = False
                For Each xCell In xRg
                    xRet = Split(xCell.Value, ".")
                    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 em thử chạy chạy code đây ạ :

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



- Khi em nhấn vào xử lý văn bản nó sẽ hiện box yêu cầu chọn số hàng số cột chứa văn bản cần tách :

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


- Sau khi chọn văn bản cần tách nó hiện ra thêm 1 box nữa để trỏ đến số hàng số cột đích (Nơi chứ văn bản đã qua xử lí) :

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

Thứ em muốn sửa là loại bỏ cái box để khi nhấp vào button : "Xử Lý Văn Bản"

Sẽ tự Xử lý luôn văn bản trong Ô : A6 và trỏ thẳng sang cột I6.

Thứ 2 là em muốn xóa nhiều dấu 1 lúc ví dụ như em có 1 văn bản như sau :

"01.02,03-04x50"

Khi nhấn xử lý nó sẽ vẫn tự động xóa các dấu "." dấu "," dấu "-" và phân sang cột "Xử lý ok" như bình thường ạ.

Và số 50 sau dấu x sẽ sang ô bên cạnh nó.

Có nghĩa 01 tương ứng I6,02 tương ứng I7 thì số 50 sẽ chạy dọc bên J6-J7,bao giờ hết số vừa tách thì thôi ạ...

Mọi người giúp em với... Please :(
 
Sửa lần cuối:
V

vothanhthu

Guest
Mình có một số góp ý với bạn:
1. Thứ sau khi đọc bài của bạn thực sự Thứ KHÔNG HIỂU GÌ HẾT. Thay vì bạn viết diễn giải lê thê, sao bạn không up một tấm ảnh minh họa mình cần gì trong đó nhỉ?, như vậy ai nhìn vào cũng hiểu.

2. Tiêu đề của bạn đang vi phạm nội quy diễn đàn với tên tiêu đề chung chung, không rõ bạn muốn gì. Bạn nên sửa tiêu đề lại cho rõ ràng là bạn đang muốn gì?

3. Tiêu đề bạn ghi giúp bạn sửa Code. Trong khi đó, bài viết của bạn không hề có một đoạn code nào cả?. Phải tải file bạn về, mở và mò Code trong đó mới thấy đc Code muốn giúp đỡ của bạn?. Bạn có thể tham khảo cách viết bài trên diễn đàn để có thể đưa code lên bài viết.
Bạn cần đăng nhập để thấy link
 
tuhocvba

tuhocvba

Administrator
Thành viên BQT
Bạn mua cái máy giặt hay tủ lạnh, có thấy bên trong người ta ghi hướng dẫn sử dụng đầy đủ không?
Hiện trạng đang là gì, cái gì làm được rồi, cái gì chưa làm được. Muốn giúp ở đâu.

Muốn người khác giúp, nhưng vứt cái data như thế này thì hơn bố tướng thiên hạ. Còn hơn cả sếp của tôi ở công ty.
 
N

n3ono1

Yêu THVBA
vothanhthu nói:
Mình có một số góp ý với bạn:
1. Thứ sau khi đọc bài của bạn thực sự Thứ KHÔNG HIỂU GÌ HẾT. Thay vì bạn viết diễn giải lê thê, sao bạn không up một tấm ảnh minh họa mình cần gì trong đó nhỉ?, như vậy ai nhìn vào cũng hiểu.

2. Tiêu đề của bạn đang vi phạm nội quy diễn đàn với tên tiêu đề chung chung, không rõ bạn muốn gì. Bạn nên sửa tiêu đề lại cho rõ ràng là bạn đang muốn gì?

3. Tiêu đề bạn ghi giúp bạn sửa Code. Trong khi đó, bài viết của bạn không hề có một đoạn code nào cả?. Phải tải file bạn về, mở và mò Code trong đó mới thấy đc Code muốn giúp đỡ của bạn?. Bạn có thể tham khảo cách viết bài trên diễn đàn để có thể đưa code lên bài viết.
Bạn cần đăng nhập để thấy link
Nhấn để mở rộng...
Em cảm ơn Mod và Admin đã nhắc nhở và chỉ dạy rất nhiệt tình,em đã sửa lại tiêu đề,thêm code và ảnh vào bài biết... Mong mọi người giúp em tìm cách xử lí vấn đề trên với ạ...
Chân thành cảm ơn mọi người rất nhiều ạ :)
 
giaiphapvba

giaiphapvba

Administrator
Thành viên BQT
Bài viết #1 đã tương đối dễ hiểu. Tuy nhiên vẫn có thể trình bày cho dễ hiểu hơn.
-Một là trong tay bạn đang có những gì? Cần mô tả cặn kẽ cách sử dụng bằng hình ảnh.
-Hai là bạn muốn cải tiến ở đâu.
Những người tham gia diễn đàn đều là những người thực sự bận rộn, họ không có nhiều thời gian, giúp bạn đã là giúp không công, không tiền, không trả công, vậy thì làm sao để họ mất ít thời gian nhất có thể, do đó bạn phải tận tâm trong trình bày.
Dưới đây tôi trình bày lại bài #1, bạn xem có dễ hiểu hơn không nhé.
=============================================
Vấn đề 1: Xử lý logic muốn cải thiện
INPUT: 01.02.03.04.05.06.07-08x10
OUTPUT: 01,02,03,04,05,06,07,08,10

Hiện nay code chỉ xử lý được như sau:
INPUT:01.02.03.04.05
OUTPUT: 01,02,03,04,05

Vấn đề 2: Cải thiện thao tác người dùng:
Bạn cần đăng nhập để thấy hình ảnh
 
B

bvtvba

Guest
Dựa vào yêu cầu của #5 tôi sửa code như sau:
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
    Dim s           As String, kqtemp As String, gttemp As String 'tuhocvba.net
    Const phantach  As String = ".-x" 'tuhocvba.net
    On Error Resume Next
    xAddress = Application.ActiveWindow.RangeSelection.Address
    Set xRg = ActiveWorkbook.ActiveSheet.Range("A6")
    Set xRg1 = ActiveWorkbook.ActiveSheet.Range("I6")
   
 
    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
Bạn cần đăng nhập để thấy hình ảnh
 
N

n3ono1

Yêu THVBA
bvtvba nói:
Dựa vào yêu cầu của #5 tôi sửa code như sau:
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
    Dim s           As String, kqtemp As String, gttemp As String 'tuhocvba.net
    Const phantach  As String = ".-x" 'tuhocvba.net
    On Error Resume Next
    xAddress = Application.ActiveWindow.RangeSelection.Address
    Set xRg = ActiveWorkbook.ActiveSheet.Range("A6")
    Set xRg1 = ActiveWorkbook.ActiveSheet.Range("I6")
  

    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
Bạn cần đăng nhập để thấy hình ảnh
Nhấn để mở rộng...
Em cảm ơn bác đã giúp em xử lý vấn đề trên của em.
Thật sự em không biết lập trình,nhưng do công việc em buộc phải cần đến 1 số chức năng đó,lên em mới cố gắng tìm hiểu ạ.
Em chân thành cảm ơn bác 1 lần nữa ạ. :)
 
Bạn phải đăng nhập hoặc đăng ký để bình luận.
Top