Giúp code tách tên hàng theo từng tên nhân viên

[hondacrv2019]

Chào cả nhà GPE! em cần 1 đoạn code tách tên hàng theo từng tên nhân viên như hình ảnh bên dưới


Ghi chú: 1 tên hàng chỉ tầm 5 nhân viên thôi, và tên nhân viên không phân biệt chữ hoa chữ thường.
tên nhân viên ghi em công thức: Nhân viên 1-Nhân viên 2-...
em xin chân thành cảm ơn !

 

[Phuocam]

Chắc bài này khó quá, nên diễn đàn này làm không nổi! hehe.

 

[SA_DQ]

Đây, macro của bạn:

Sub LapBangThongKe()
Dim Cls As Range:                               Const FC As String = "-"
Dim Tho As String, THg As String
Dim Rws As Long, W As Integer, VTr As Byte, SoLg As Integer, TTien As Double

Rws = [C4].CurrentRegion.Rows.Count * 5
ReDim Arr(1 To Rws, 1 To 4):               [F3].CurrentRegion.Offset(2).ClearContents
For Each Cls In Range([D4], [D4].End(xlDown))
    Tho = Cls.Value & FC:                       THg = Cls.Offset(, -3).Value
    SoLg = Cls.Offset(, -2).Value:            TTien = Cls.Offset(, -1).Value
    Do
        VTr = InStr(Tho, FC):               If VTr < 1 Then Exit Do
        W = W + 1:                                   Arr(W, 2) = THg
        Arr(W, 3) = SoLg:                          Arr(W, 4) = TTien
        Arr(W, 1) = Left(Tho, VTr - 1):       Tho = Mid(Tho, VTr + 1, Len(Tho))
    Loop
Next Cls
[f4].Resize(W, 4).Value = Arr()
End Sub

 

[hondacrv2019]

Đây, macro của bạn:

Sub LapBangThongKe()
Dim Cls As Range:                               Const FC As String = "-"
Dim Tho As String, THg As String
Dim Rws As Long, W As Integer, VTr As Byte, SoLg As Integer, TTien As Double

Rws = [C4].CurrentRegion.Rows.Count * 5
ReDim Arr(1 To Rws, 1 To 4):               [F3].CurrentRegion.Offset(2).ClearContents
For Each Cls In Range([D4], [D4].End(xlDown))
    Tho = Cls.Value & FC:                       THg = Cls.Offset(, -3).Value
    SoLg = Cls.Offset(, -2).Value:            TTien = Cls.Offset(, -1).Value
    Do
        VTr = InStr(Tho, FC):               If VTr < 1 Then Exit Do
        W = W + 1:                                   Arr(W, 2) = THg
        Arr(W, 3) = SoLg:                          Arr(W, 4) = TTien
        Arr(W, 1) = Left(Tho, VTr - 1):       Tho = Mid(Tho, VTr + 1, Len(Tho))
    Loop
Next Cls
[f4].Resize(W, 4).Value = Arr()
End Sub

CẢM ƠN BÁC. Bác cỏ thể xử lý ngay dòng màu đỏ cho nó ra thành tiền là 100k được không bác

 

[SA_DQ]

Thực hiện theo iêu cầu của bạn thì dòng cuối sẽ là 700K chứ nhỉ?

Sub LapBangThongKe()
 Dim Cls As Range:                               Const FC As String = "-"
 Dim Tho As String, THg As String
 Dim Rws As Long, W As Integer, VTr As Byte, SoLg As Integer, TTien As Double
  
 Rws = [C4].CurrentRegion.Rows.Count * 5
 ReDim Arr(1 To Rws, 1 To 4):               [F3].CurrentRegion.Offset(2).ClearContents
 For Each Cls In Range([D4], [D4].End(xlDown))
    Tho = Cls.Value & FC:                       THg = Cls.Offset(, -3).Value
    SoLg = Cls.Offset(, -2).Value:            TTien = Cls.Offset(, -1).Value
    Do
        VTr = InStr(Tho, FC):                    If VTr < 1 Then Exit Do
        W = W + 1:                                   Arr(W, 2) = THg
        Arr(W, 3) = SoLg:                          Arr(W, 4) = TTien * SoLg         '** '
        Arr(W, 1) = Left(Tho, VTr - 1):       Tho = Mid(Tho, VTr + 1, Len(Tho))
    Loop
 Next Cls
 [f4].Resize(W, 4).Value = Arr()
End Sub

 

[hondacrv2019]

Thực hiện theo iêu cầu của bạn thì dòng cuối sẽ là 700K chứ nhỉ?

dạ đúng rồi bác. em muốn ra thành tiền luôn

Bài đã được tự động gộp: 15/12/19

Thực hiện theo iêu cầu của bạn thì dòng cuối sẽ là 700K chứ nhỉ?

Sub LapBangThongKe()
Dim Cls As Range:                               Const FC As String = "-"
Dim Tho As String, THg As String
Dim Rws As Long, W As Integer, VTr As Byte, SoLg As Integer, TTien As Double
 
Rws = [C4].CurrentRegion.Rows.Count * 5
ReDim Arr(1 To Rws, 1 To 4):               [F3].CurrentRegion.Offset(2).ClearContents
For Each Cls In Range([D4], [D4].End(xlDown))
    Tho = Cls.Value & FC:                       THg = Cls.Offset(, -3).Value
    SoLg = Cls.Offset(, -2).Value:            TTien = Cls.Offset(, -1).Value
    Do
        VTr = InStr(Tho, FC):                    If VTr < 1 Then Exit Do
        W = W + 1:                                   Arr(W, 2) = THg
        Arr(W, 3) = SoLg:                          Arr(W, 4) = TTien * SoLg         '** '
        Arr(W, 1) = Left(Tho, VTr - 1):       Tho = Mid(Tho, VTr + 1, Len(Tho))
    Loop
Next Cls
[f4].Resize(W, 4).Value = Arr()
End Sub

quá tuyệt vời em cảm ơn bác

 

[VetMini]

Chắc bài này khó quá, nên diễn đàn này làm không nổi! hehe.

Bài này khó ở chỗ trình bày yêu cầu chưa rõ rệt.

Thớt nói rằng:
- dữ liệu có khoảng 5000 dòng
- có tất cả 5 nhân viên
- những dòng dữ liệu trên được lập theo dạng gộp ngang (crosstabed) theo tên nhân viên
Như vậy nếu unpivot ra để tính thì sẽ ra khoảng từ 5000 đến 25000 phát sinh.

Nhưng thớt không hề cho biết sau khi tính ra thì có gộp theo hàng dọc hay không?
gộp theo tên nhân viên + tên hàng ?
Và cuối cùng: có cần sắp xếp kết quả hay không? Theo như mẫu thì có thể có sắp xếp theo tên hàng + tên nhân viên, nhưng cũng có thể do ngẫu nhiên tùng hợp.

Nếu trả lời các câu hỏi ở trên đều là "không" thì bài toán chỉ giản dị là unpivot.