Macro click chuột tách chuỗi ký tự trong cell (2 người xem)

[overnight_9]

Chào anh chị diễn đàn GPE.
Anh chị giúp tôi tạo 1 macro tách chuỗi ký tự trong cell.
tôi có 1 bảng tính gồm 2 sheet (dulieu_tho & TH chitiet) sẽ tách dữ
liệu qua sheet (TH chitiet) gồ 4 cột, (Danh Mục & Màu & ĐVT & Định Mức) khi click chuột vào cell của cột Danh Mục thì macro sẽ tách 1 chuổi ký tự được phân định bằng dấu (+). Và tương ứng click chuột vào cell của cột Màu thì macro sẽ tách chuỗi hoặc 1 ký tự được phân định bằng dấu (/). Và cell của cột Định Mức xét theo điều kiện cell của cột ĐVT. tôi có đính kèm file anh chị nghiên cứu giúp tôi con macro này. chân thành cám ơn

 

[Quang_Hải]

Bạn xem file đính kèm, phải sort cột B trước mới chạy macro nha

Sub tach()
Dim dic As Object
Dim arrkq()
Set dic = CreateObject("scripting.dictionary")
dl = Range([B2], [L65536].End(3)).Value
ReDim arrkq(1 To UBound(dl, 1), 1 To 4)
With dic
    For i = 1 To UBound(dl)
        dk = Trim(Left(dl(i, 1), InStr(dl(i, 1), "+") - 1))
        If Not .exists(dk) Then
            .Add dk, ""
            j = j + 1
            arrkq(j, 1) = dk
            arrkq(j, 2) = Trim(Left(dl(i, 6), InStr(dl(i, 6), "/") - 1))
            arrkq(j, 3) = dl(i, 10)
            arrkq(j, 4) = dl(i, 11)
        Else
            arrkq(j, 4) = arrkq(j, 4) + dl(i, 11)
        End If
    Next
 Sheets("tonghop").[B2].Resize(j, 4) = arrkq
End With
End Sub

 

[Quang_Hải]

Code này không cần sort dữ liệu vẫn có thể ra kết quả đúng

Sub tach()
Dim dic As Object
Dim arrkq()
Set dic = CreateObject("scripting.dictionary")
dl = Range([B2], [L65536].End(3)).Value
ReDim arrkq(1 To UBound(dl, 1), 1 To 3)
With dic
    For i = 1 To UBound(dl)
        dk = Trim(Left(dl(i, 1), InStr(dl(i, 1), "+") - 1))
        If Not .exists(dk) Then
            .Add dk, dl(i, 11)
            j = j + 1
            arrkq(j, 1) = dk
            arrkq(j, 2) = Trim(Left(dl(i, 6), InStr(dl(i, 6), "/") - 1))
            arrkq(j, 3) = dl(i, 10)
            
        Else
            .Item(dk) = .Item(dk) + dl(i, 11)
        End If
    Next
Sheets("tonghop").[B2].Resize(j, 3) = arrkq
Sheets("tonghop").[e2].Resize(j, 1) = Application.Transpose(.Items)
End With
End Sub

 

[overnight_9]

Hi anh QuangHai,
ý tôi là tách hết 1 chuỗi ký tự, nếu chuỗi này có 4 or 5 nhóm thì tách ra từng nhóm. Mục đích là tách dữ liệu liệu qua sheet (TH chitiet) gồ 4 cột, (Danh Mục & Màu & ĐVT & Định Mức) khi click chuột vào cell của cột Danh Mục thì macro sẽ tách 1 chuổi ký tự được phân định bằng dấu (+). Và tương ứng click chuột vào cell của cột Màu thì macro sẽ tách chuỗi hoặc 1 ký tự được phân định bằng dấu (/). Và cell của cột Định Mức xét theo điều kiện cell của cột ĐVT. tôi có đính kèm lại file, TH chitiet là sheet yêu cầu. sorry vì file trước yêu cầu chưa rõ.

 

[sealand]

Code của QuangHai e tách chưa hết, mình tham gia code sau và cho kết quả khác nhiều. "Khổ chủ" cho ý kiến nha:

Sub TH()
Dim dic As Object
Dim Tm, i, j, Tm1, Tm2
Sheet2.[A2:D1000].ClearContents
Set dic = CreateObject("scripting.dictionary")
Tm = Sheet1.Range(Sheet1.[B2], Sheet1.[B65536].End(3)).Resize(, 11)
For i = 1 To UBound(Tm, 1)
Tm1 = Split(Tm(i, 1), "+")
Tm2 = Split(Tm(i, 6), "/")
For j = 0 To UBound(Tm1) - 1
If dic.exists(Tm1(j) & "+" & Tm2(j) & "+" & Tm(i, 10)) Then
dic.Item(Tm1(j) & "+" & Tm2(j) & "+" & Tm(i, 10)) = _
dic.Item(Tm1(j) & "+" & Tm2(j) & "+" & Tm(i, 10)) + Tm(i, 11)
Else
dic.Add Tm1(j) & "+" & Tm2(j) & "+" & Tm(i, 10), Tm(i, 11)
End If
Next j
Next i
Tm1 = dic.keys
Tm2 = dic.Items
For i = 0 To dic.Count - 1
Tm = Split(Tm1(i), "+")
Sheet2.Cells(i + 2, 1) = Tm(0)
Sheet2.Cells(i + 2, 2) = Tm(1)
Sheet2.Cells(i + 2, 3) = Tm(2)
Sheet2.Cells(i + 2, 4) = Tm2(i)
Next
End Sub

Lần sau tác giả Topic cho anh em dùng đồ cổ xin file ví dụ bằng Ex 2003 với nha

 

[overnight_9]

Code của QuangHai e tách chưa hết, mình tham khảo code sau và cho kết quả khác nhiều. "Khổ chủ" cho ý kiến nha:

Cám ơn anh Sealand nhiều, nhưng vẫn chưa hết ý, anh xem lại giúp lần nữa. trong file sheet "TH chitiet" là yêu cầu. mình yêu cầu là
tách tất cả các dòng của Danh Mục, Màu dù có trùng lập, nhưng cột Định Mức thì số khác nhau, ở đây mình không tổng ở cell ĐM mà có 2 điều kiện nếu cột ĐVT là "Set" thì 1 chia cell đó, nếu ĐVT là "Pcs" thì trả về giá trị cell đó.

Cái commandbutton được thay thế bởi "click mouse" bất cứ cell nào trong cột Danh Mục đươc không anh?

 

[concogia]

Cám ơn anh Sealand nhiều, nhưng vẫn chưa hết ý, anh xem lại giúp lần nữa. trong file sheet "TH chitiet" là yêu cầu. mình yêu cầu là
tách tất cả các dòng của Danh Mục, Màu dù có trùng lập, nhưng cột Định Mức thì số khác nhau, ở đây mình không tổng ở cell ĐM mà có 2 điều kiện nếu cột ĐVT là "Set" thì 1 chia cell đó, nếu ĐVT là "Pcs" thì trả về giá trị cell đó.

Cái commandbutton được thay thế bởi "click mouse" bất cứ cell nào trong cột Danh Mục đươc không anh?

Hãy nói rõ chỗ này
1)- "click mouse" vào hàng nào trong danh mục thì nó chỉ tách hàng đó hay "click mouse" vào bất cứ hàng nào trong cột danh mục thì có bao nhiêu hàng thì nó tách hết bấy nhiêu ?????
2)- Bạn diễn tả thao tác "click mouse" theo ý bạn là như thế nào để anh em muốn giúp bạn dễ làm ( khỏi phải đoán )

 

[overnight_9]

Hãy nói rõ chỗ này
1)- "click mouse" vào hàng nào trong danh mục thì nó chỉ tách hàng đó hay "click mouse" vào bất cứ hàng nào trong cột danh mục thì có bao nhiêu hàng thì nó tách hết bấy nhiêu ?????
2)- Bạn diễn tả thao tác "click mouse" theo ý bạn là như thế nào để anh em muốn giúp bạn dễ làm ( khỏi phải đoán )

Thanks Concogia, #1, click mouse cell nào trong cột DM thì tách dòng đó. #2 giả sử trong sheet(dulieu_tho) cột DM có đến 300 or N dòng thì khi ta click đến cell nào thì sẽ tách dòng đó theo tiêu chí (Danh Mục, Màu, ĐVT, Mô Tả, Định Mức), qua sheet(TH_chitiet). cám ơn anh chị.

 

[Ba Tê]

Thanks Concogia, #1, click mouse cell nào trong cột DM thì tách dòng đó. #2 giả sử trong sheet(dulieu_tho) cột DM có đến 300 or N dòng thì khi ta click đến cell nào thì sẽ tách dòng đó theo tiêu chí (Danh Mục, Màu, ĐVT, Mô Tả, Định Mức), qua sheet(TH_chitiet). cám ơn anh chị.

Click rồi click nữa, click nữa ... thì sao? Chọn cách này chi cho lu xu bu nhỉ?

 

[Quang_Hải]

Tách 1 lần cho gọn đi

 

[concogia]

Thanks Concogia, #1, click mouse cell nào trong cột DM thì tách dòng đó. #2 giả sử trong sheet(dulieu_tho) cột DM có đến 300 or N dòng thì khi ta click đến cell nào thì sẽ tách dòng đó theo tiêu chí (Danh Mục, Màu, ĐVT, Mô Tả, Định Mức), qua sheet(TH_chitiet). cám ơn anh chị.

Làm theo ý bạn nhé
Nói như Ba Tê, click rồi lại click đúng nó thì kết quả ra 2 lần thì bạn.....ráng chịu
Còn cái số thứ tự nữa, vì bạn thí dụ đúng theo thứ tự bên sheet dulieu_tho nên chẳng biết đánh số thứ tự ở kết quả như thế nào nữa, thôi cứ tạm thế này có gì bàn tiếp
Thú thực, yêu cầu của bạn hơi ....ngộ
Thân
Híc

 

[overnight_9]

Click rồi click nữa, click nữa ... thì sao? Chọn cách này chi cho lu xu bu nhỉ?

Thanks anh BaTe rat nhieu, em cũng đang nghĩ thấy thiếu gì đó! may nhờ có anh. Mình click 1 lần thôi anh sau khi thỏa điều kiện thì đánh dấu bằng cách tô màu (Yello, dark Blue...) cho cell đó, nếu click lần 2 để code thực hiện thì cell này không có màu, nếu không thì code không thực hiện, cám ơn anh nhiều.

 

[overnight_9]

Làm theo ý bạn nhé..........
Thú thực, yêu cầu của bạn hơi ....ngộ
Thân
Híc

ô Thanks a lot Concogia, tuyệt thật nhưng em vừa post lên 1 ý trong lúc em chưa check toptic của anh, anh check lại cái ý này 1 lần nữa giúp em được không anh?

Thanks anh BaTe rat nhieu, em cũng đang nghĩ thấy thiếu gì đó! may nhờ có anh. Mình click 1 lần thôi anh sau khi thỏa điều kiện thì đánh dấu bằng cách tô màu (Yello, dark Blue...) cho cell đó, nếu click lần 2 để code thực hiện thì cell này không có màu, nếu không thì code không thực hiện, cám ơn anh nhiều.

 

[concogia]

ô Thanks a lot Concogia, tuyệt thật nhưng em vừa post lên 1 ý trong lúc em chưa check toptic của anh, anh check lại cái ý này 1 lần nữa giúp em được không anh?

Đây
Dù vậy, vẫn....ngộ
Thân
Híc

 

[Quang_Hải]

Làm theo ý bạn nhé
Nói như Ba Tê, click rồi lại click đúng nó thì kết quả ra 2 lần thì bạn.....ráng chịu
Còn cái số thứ tự nữa, vì bạn thí dụ đúng theo thứ tự bên sheet dulieu_tho nên chẳng biết đánh số thứ tự ở kết quả như thế nào nữa, thôi cứ tạm thế này có gì bàn tiếp
Thú thực, yêu cầu của bạn hơi ....ngộ
Thân
Híc

Cảm ơn anh Cò, em đang loay hoay chưa biết làm sao để đếm cái mảng Split, giờ mới hiểu.
Nếu mình mà nhấp chuột chắc nó qua 1 lúc 3 lần quá, hic.

 

[overnight_9]

Một lần nữa cám ơn 3 anh (QuangHai, Concogia, Bate) đúng ý em rồi.

Dù vậy, vẫn....ngộ

thật tình công việc em cũng ngộ lắm, nên em không biết giải thích thế nào nữa Hic!

chúc sức khõe các anh.

 

[overnight_9]

Hi anh các anh,
nhờ các anh giúp em chỉnh lại tí code giúp, Trong sheet(dulieu_tho) bây có một số thay đổi theo biểu mẫu, em định XÀO CHẼ (bịt mắt bắt dê) mà lổi tùm lum nhìn không ra.

1. cell Màu đổi đứng trước cell Danh Mục.
2. trong sheet(dulieu_tho) này có 2 vùng dữ liệu (vùng 1 & vùng 2) điều được tách qua TH_chitiet.
3.Các anh chỉ giúp nếu đây là macro chính thức thì một khi em muốn tách bất kỳ file nào (có cùng định dạng) thì em sẽ gọi macro này ra để thực hiện. em cám ơn các anh nhiều nhiều.

 

[concogia]

Hi anh các anh,
nhờ các anh giúp em chỉnh lại tí code giúp, Trong sheet(dulieu_tho) bây có một số thay đổi theo biểu mẫu, em định XÀO CHẼ (bịt mắt bắt dê) mà lổi tùm lum nhìn không ra.

1. cell Màu đổi đứng trước cell Danh Mục.
2. trong sheet(dulieu_tho) này có 2 vùng dữ liệu (vùng 1 & vùng 2) điều được tách qua TH_chitiet.
3.Các anh chỉ giúp nếu đây là macro chính thức thì một khi em muốn tách bất kỳ file nào (có cùng định dạng) thì em sẽ gọi macro này ra để thực hiện. em cám ơn các anh nhiều nhiều.

Càng lúc càng....ngộ, XÀO CHẼ (bịt mắt bắt dê) vậy là ngon rồi, tiếp tục xào một thời gian sẽ Ok thôi
Câu 3: được nếu cùng định dạng, khai báo các địa chỉ vùng dữ liệu chính xác là.........chạy
Nếu chạy mà .....trật thì......lại gởi bài lên hỏi tiếp
Híc

 

[overnight_9]

Càng lúc càng....ngộ, XÀO CHẼ (bịt mắt bắt dê) vậy là ngon rồi, tiếp tục xào một thời gian sẽ Ok thôi
Câu 3: được nếu cùng định dạng, khai báo các địa chỉ vùng dữ liệu chính xác là.........chạy
Nếu chạy mà .....trật thì......lại gởi bài lên hỏi tiếp
Híc

Cám ơn anh Concogia rất nhiều, tại sao mình mới biết GPE mới đây nhỉ? đúng là tấm gương soi sáng cho tuổi trẻ chúng em.

 

[overnight_9]

Câu 3: được nếu cùng định dạng, khai báo các địa chỉ vùng dữ liệu chính xác là.........chạy
Nếu chạy mà .....trật thì......lại gởi bài lên hỏi tiếp

hi anh Concogia, anh kiểm tra giúp vì em có thêm 1 điều kiện trong code này là, nếu tách cột Màu mà nhóm màu không tương ứng với nhóm VT thì show thông báo, em làm chưa đúng nó báo lỗi, mong anh giúp đỡ.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 Dim Vung, I, J, kK, Mg, TachDm, TachMau, Tong, K, A, B
    If Not Intersect(Target, Range([K24], [K10000].End(xlUp))) Is Nothing Or Not Intersect(Target, Range([AI24], [AI10000].End(xlUp))) Is Nothing Then
   If ActiveCell.Interior.ColorIndex = 6 Then
    UserForm1.Show
    Else
    Vung = ActiveCell.Offset(, -3).Resize(, 14)
        Tong = Tong + Len(ActiveCell) - Len(Replace(ActiveCell, "+", "")) + 1
        ReDim Mg(1 To Tong, 1 To 5)
                TachDm = Split(ActiveCell, "+")
                TachMau = Split(Vung(1, 1), "/")
                For J = LBound(TachDm) To UBound(TachDm)
                    K = K + 1
                    If TachMau = "" Then
                    UserForm2.Show
                    Else
                      Mg(K, 1) = TachDm(J): Mg(K, 2) = TachMau(J): Mg(K, 3) = Vung(1, 12): Mg(K, 4) = Vung(1, 11): Mg(K, 5) = IIf(Mg(K, 3) = "M", 1 / Vung(1, 14), Vung(1, 14))
                Next J
    ActiveCell.Interior.ColorIndex = 6
 Dim Ws As Worksheet
 Set Ws = Workbooks("TH_chitiet.xlsm").Worksheets("TH_chitiet")
    With Ws.[B1000].End(xlUp)(2)
        If .Row = 5 Then
            .Offset(, -1) = 1
        Else
            .Offset(, -1) = 1 + Application.WorksheetFunction.Max(Ws.Range((Ws.[B5]), (Ws.[B10000].End(xlUp))).Offset(, -1))
        End If
    End With
    Ws.[B1000].End(xlUp)(2).Resize(K, 5) = Mg
    Ws.Select
    
    End If
    End If
    
    Set Ws = Nothing
End Sub