Pls viết hộ Code "gộp mã theo điều kiện"

  • Thread starter Thread starter ThuNghi
  • Ngày gửi Ngày gửi
Liên hệ QC
T

ThuNghi

Hãy cho rồi sẽ nhận!
Thành viên đã mất
Tham gia
16/8/06
Bài viết
3,808
Được thích
4,449
Tôi có dữ liệu như file kèm theo, cụ thể là
SoCT---SoHD
PT01---001
PT01---002
PT02---003
PT02---004
PT02---005
Tôi muốn viết code làm sao để được
SoCT---SoHD
PT01---001; 002
PT02---003; 004;005
Nghĩa là gom SoHD lại nếu SoCT giống nhau.
Đúng ra phần này là Topic kế toán, nhưng vì cần viết code nên mới đưa sang đây.
Một SoCT có thể có nhiều nhất 10 SoHD.
Cám ơn nhiều!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
ThuNghi đã viết:
Tôi có dữ liệu như file kèm theo, cụ thể là
SoCT---SoHD
PT01---001
PT01---002
PT02---003
PT02---004
PT02---005
Tôi muốn viết code làm sao để được
SoCT---SoHD
PT01---001; 002
PT02---003; 004;005
Nghĩa là gom SoHD lại nếu SoCT giống nhau.
Đúng ra phần này là Topic kế toán, nhưng vì cần viết code nên mới đưa sang đây.
Một SoCT có thể có nhiều nhất 10 SoHD.
Cám ơn nhiều!
Nhấp chuột vào đây để mở rộng...

Bác muốn viết bằng UDF hay Sub vậy ạ ???

Thân!
 
Upvote 0
Sub nha! Mình muốn tự chạy tạo ra data ThuChi khi lấy dữ liệu. Cám ơn nhiều, c. hơi gấp.
Nhấp chuột vào đây để mở rộng...
--=0
PHP: 
Option Explicit
Sub GopPhieu() ' GPE.COM'
 Dim lRow As Long, eRow As Long, Ww As Long
 Dim Clls As Range, Rng As Range
 Dim GPE_Address As String, SoHD As String
 
 Sheet1.Select: lRow = [a65432].End(xlUp).Row
 Range([k4], Cells(lRow, "T")).Clear: Application.ScreenUpdating = False
 Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[K3], Unique:=True
 For Ww = 4 To [k65500].End(xlUp).Row
    With Range("A4:A" & lRow)
        Set Clls = .Find(Cells(Ww, "K"), LookIn:=xlValues)
        If Not Clls Is Nothing Then
            GPE_Address = Clls.Address
            Do
                If Rng Is Nothing Then
                    Set Rng = Clls.Resize(, 9)
                Else
                     Set Rng = Union(Rng, Clls.Resize(, 9))
                End If
                Set Clls = .FindNext(Clls)
            Loop While Not Clls Is Nothing And Clls.Address <> GPE_Address
        End If
        If Not Rng Is Nothing Then
             Cells(Ww, "l").Resize(, 7) = Rng.Cells(1, 3).Resize(, 7).Value
             Cells(Ww, "R") = WorksheetFunction.Sum(Range(Rng.Cells(1, 9), _
                      Rng.Cells(Rng.Rows.Count, 9)))
'[SoHD]==>> here'
              For Each Clls In Range(Rng.Cells(1, 2), Rng.Cells(Rng.Rows.Count, 2))
                    If SoHD = "" Then
                           SoHD = Clls.Value
                    ElseIf SoHD <> Clls.Value And InStr(SoHD, Clls.Value) = 0 Then
                           SoHD = SoHD & ", " & Clls.Value
                    End If
               Next Clls
               Cells(Ww, "s") = SoHD: SoHD = ""
' [TKCo] ==>> here'
 
'ThuNghi Tu Viet Nha!'
 
               Set Rng = Nothing
         End If
    End With
 
Next Ww
End Sub
)(&&@@
 

File đính kèm

Chỉnh sửa lần cuối bởi điều hành viên:
Upvote 0
Anh xem code này thử
PHP: 
Sub Taodulieu()
Dim Rdata As Long, i As Long, Rw As Long, Rlk As Long, DemHD As Byte
Dim SoCT As Range, Data As Range, Ws As Object
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rdata = [A65536].End(xlUp).Row
Set SoCT = Range("A4:A" & Rdata)
Set Sotien = SoCT.Offset(, 8)
Set Data = SoCT.Resize(, 9)
Set Ws = WorksheetFunction
Range("K4:S65536").ClearContents
Range("A3:A" & Rdata).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[K3], Unique:=True
Rw = [K65536].End(xlUp).Row
For i = 4 To Rw
    With Cells(i, 11)
        Rlk = Ws.Match(.Value, SoCT, 0) + 3
        .Offset(, 1) = Cells(Rlk, 3)
        .Offset(, 2) = Cells(Rlk, 4)
        .Offset(, 3) = Cells(Rlk, 5)
        .Offset(, 4) = Cells(Rlk, 6)
        'Tim TK No
        If Cells(Rlk, 7) = Cells(Rlk + 1, 7) Then
        .Offset(, 5) = Cells(Rlk, 7)
        Else: .Offset(, 5) = Cells(Rlk, 7) & ", " & Cells(Rlk + 1, 7)
        End If
        'Tim TK Co
        If Cells(Rlk, 8) = Cells(Rlk + 1, 8) Then
        .Offset(, 6) = Cells(Rlk, 8)
        Else: .Offset(, 6) = Cells(Rlk, 8) & ", " & Cells(Rlk + 1, 8)
        End If
        'Tim SoHD : VD o day la 1 chung tu co 3 hoa don
        DemHD = Ws.CountIf(SoCT, .Value) / 2
        Select Case DemHD
            Case 1: .Offset(, 8) = Cells(Rlk, 2)
            Case 2: .Offset(, 8) = Cells(Rlk, 2) & ", " & Cells(Rlk + 2, 2)
            Case 3: .Offset(, 8) = Cells(Rlk, 2) & ", " & Cells(Rlk + 2, 2) & ", " & Cells(Rlk + 4, 2)
            '.......................
            'Case n voi n so hoa don
        End Select
        'Tim So tien
        .Offset(, 7) = Ws.SumIf(SoCT, .Value, Sotien)
    End With
Next
Set SoCT = Nothing: Set Sotien = Nothing: Set Data = Nothing: Set Ws = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 

File đính kèm

Upvote 0
ThuNghi đã viết:
Sub nha! Mình muốn tự chạy tạo ra data ThuChi khi lấy dữ liệu. Cám ơn nhiều, cần hơi gấp.
Nhấp chuột vào đây để mở rộng...


Bác thử nhé : Hai Phương án

Phương án 1 UDF :

PHP: 
Function HoaDon(Phieu As String, MangPhieu As Range, MangHD As Range) As String
    Application.Volatile (False)
    If MangPhieu.Columns.Count <> 1 Then Exit Function
    If MangHD.Columns.Count <> 1 Then Exit Function
    If MangPhieu.Rows.Count <> MangHD.Rows.Count Then Exit Function
    If Phieu = "" Then Exit Function
    
    Dim i As Long
    For i = 1 To MangPhieu.Rows.Count
        If MangPhieu(i, 1) = Phieu Then
            If Len(HoaDon) = 0 Then
                HoaDon = MangHD(i, 1)
            Else
                If InStr(1, HoaDon, MangHD(i, 1)) = 0 Then
                    HoaDon = HoaDon & "; " & MangHD(i, 1)
                End If
            End If
        End If
    Next
End Function


Phương án 2 SUB :

PHP: 
Function TimRow(Ma As String, Mang As Range) As Long
    On Error Resume Next
    TimRow = WorksheetFunction.Match(Ma, Mang, 0)
End Function


PHP: 
Sub ThuNghi()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim i As Long, iOB As Long, HC As Long
    Dim Ma As String, HD As String
    iOB = 1: HC = 1
    OB.Range("A2:B10000").ClearContents
    With TN
        For i = 2 To .Range("A65000").End(xlUp).Row
            Ma = .Range("A" & i).Value
            iOB = TimRow(Ma, OB.Range("A1:A" & HC))
            If iOB = 0 Then
                HC = HC + 1
                iOB = HC
                OB.Range("A" & iOB).Value = Ma
                OB.Range("B" & iOB).Value = " " & .Range("B" & i).Text
            Else
                HD = OB.Range("B" & iOB).Text
                If InStr(1, HD, .Range("B" & i).Text) = 0 Then
                    OB.Range("B" & iOB).Value = HD & IIf(Len(HD) > 0, "; ", "") & .Range("B" & i).Text
                End If
            End If
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


Thân!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Cám ơn các Bác nhiều lắm. Mình cũng làm 1 code nhưng vướng ở chỗ, làm sao lấy được TK đối ứng duy nhất trong 1 cell
Ví dụ: Thu tiền BH theo 02 HD thì sẽ là: 511;333;511;333, làm thêm một function nữa thì khó coi.
Các Bác xem lại hộ.
PHP: 
Sub TaoSP()
Dim SoTien As Long, SoHD As String
Dim i As Long, j As Long
Dim SoCT As String, SoCTj As String, TKNo As String, TKCo As String
With Sheet1
       eRow = .[B65000].End(xlUp).Row
       .Range("K2:U1000").ClearContents
        j = 2
        For i = 2 To eRow
            SoCT = .Range("A" & i)
            SoCTj = .Range("A" & i + 1)
            SoTien = .Range("A" & i).Offset(, 8) + SoTien
            If .Range("A" & i).Offset(, 1) <> .Range("A" & i - 1).Offset(, 1) Then
                SoHD = .Range("A" & i).Offset(, 1) & "; " & SoHD
            End If
            Select Case Left(SoCT, 2)
                Case "PC"
                    TKCo = "1111"
                    TKNo = .Range("A" & i).Offset(, 6) & "; " & TKNo
                Case "PT"
                    TKNo = "1111"
                    TKCo = .Range("A" & i).Offset(, 7) & "; " & TKCo
            End Select
            
            If SoCT <> SoCTj Then
                 .Range("K" & j) = SoCT
                 .Range("K" & j).Offset(, 1) = .Range("A" & i).Offset(, 2) 'Ngayht
                .Range("K" & j).Offset(, 2) = .Range("A" & i).Offset(, 4) 'NoiDung
                .Range("K" & j).Offset(, 3) = .Range("A" & i).Offset(, 5) 'DienGiai
                 .Range("K" & j).Offset(, 4) = SoTien
                 SoHD = Left(SoHD, Len(SoHD) - 2)
                 TKNo = Left(TKNo, Len(TKNo) - 2)
                 TKCo = Left(TKCo, Len(TKCo) - 2)
                 .Range("K" & j).Offset(, 5) = SoHD
                 .Range("K" & j).Offset(, 6) = TKNo
                 .Range("K" & j).Offset(, 7) = TKCo
                 SoHD = ""
                 TKNo = ""
                 TKCo = ""
                 SoTien = 0
                  j = j + 1
               
            End If
            
        Next
        
  End With
End Sub
 
Upvote 0
File trên của em chưa được hả bác ???

Bác dùng Sub cũng được, mà dùng UDF cũng được mà.

Thân!
 
Upvote 0
ThuNghi đã viết:
Cám ơn các Bác nhiều lắm. Mình cũng làm 1 code nhưng vướng ở chỗ, làm sao lấy được TK đối ứng duy nhất trong 1 cell
Ví dụ: Thu tiền BH theo 02 HD thì sẽ là: 511;333;511;333, làm thêm một function nữa thì khó coi. Các Bác xem lại hộ.
Nhấp chuột vào đây để mở rộng...
Dùng hàm InStr(...,...)<>0 để không chép trùng, có được không vậy, TNg?!

theo kiểu:
Mã: 
     If [COLOR=#0000bb]SoHD [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#dd0000]"" [/COLOR][COLOR=#0000bb]Then[/COLOR]
[COLOR=#0000bb]              SoHD [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value[/COLOR]
[COLOR=#007700]     ElseIf [/COLOR][COLOR=#0000bb]SoHD [/COLOR][COLOR=#007700]<> [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value [/COLOR][COLOR=#007700]And [/COLOR][COLOR=#0000bb]InStr[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]SoHD[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#0000bb]0 Then[/COLOR]
[COLOR=#0000bb]              SoHD [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]SoHD [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#dd0000]", " [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value[/COLOR]
[COLOR=#0000bb]     End [/COLOR][COLOR=#007700]If[/COLOR]
 
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote 0
HYen17 đã viết:
Dùng hàm InStr(...,...)<>0 để không chép trùng, có được không vậy, TNg?!

theo kiểu:
Mã: 
     If [COLOR=#0000bb]SoHD [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#dd0000]"" [/COLOR][COLOR=#0000bb]Then[/COLOR]
[COLOR=#0000bb]              SoHD [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value[/COLOR]
[COLOR=#007700]     ElseIf [/COLOR][COLOR=#0000bb]SoHD [/COLOR][COLOR=#007700]<> [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value [/COLOR][COLOR=#007700]And [/COLOR][COLOR=#0000bb]InStr[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]SoHD[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#0000bb]0 Then[/COLOR]
[COLOR=#0000bb]              SoHD [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]SoHD [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#dd0000]", " [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000bb]Clls[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]Value[/COLOR]
[COLOR=#0000bb]     End [/COLOR][COLOR=#007700]If[/COLOR]
Nhấp chuột vào đây để mở rộng...

Thì em cũng đã dùng rồi mà (cả UDF và SUB). : Để cho số hóa đơn chỉ xuất hiện 1 lần.

Hình như bác ThuNghi còn có ý khác ?? (liên quan đến tài khoản)

Sao bác không post file VD của bác lên nhỉ ???

Thân!
 
Upvote 0
Thu Nghi này có cái tội lớn:
Chả bao giờ cho biết kết quả của anh em người ta làm giúp được hay không được. Không chỉ ở topic này.
Giờ thì lặn mất tiêu.

Mình test thử dùm ThuNghi thì thế này:
1. Sub của Bác Sa:
Các kết quả đều đúng, trừ cột TKCo (cột Q): Thu Nghi cần "33311, 511" nhưng kết quả chỉ có "511"

2. Sub và UDF của MrOkeBab: Kết quả đúng 100%, nhưng mới chỉ làm có 1 cột liệt kê hoá đơn :)

3. Sub của HoangDanh: Đúng 100%. Nhưng mới viết sẵn cho 3 hoá đơn.
Mình xin phép góp 1 tí (lại là 1 hộp quẹt gaz) vào code HoangDanh để khỏi phải select case 10 case:
Thay vào đọan Tim SoHD Selectcase . . . End Select

PHP: 
    'Tim SoHD : VD o day la 1 chung tu co 3 hoa don'
        DemHD = Ws.CountIf(SoCT, .Value)
        ListHD = Cells(Rlk, 2)
    If DemGD = 2 Then
        .Offset(, 8) = ListHD
    Else
      For shd = 3 To DemHD Step 2
      ListHD = ListHD & ", " & Cells(Rlk + shd, 2)
      Next
      .Offset(, 8) = ListHD
    End If
 
Upvote 0
Mr Okebab đã viết:
Thì em cũng đã dùng rồi mà (cả UDF và SUB). : Để cho số hóa đơn chỉ xuất hiện 1 lần.

Hình như bác ThuNghi còn có ý khác ?? (liên quan đến tài khoản)

Sao bác không post file VD của bác lên nhỉ ???

Thân!
Nhấp chuột vào đây để mở rộng...
PHP: 
Sub TaoSP()
Dim SoTien As Long, SoHD As String
Dim i As Long, j As Long, TKNoX As String, TKCoX As String
Dim SoCT As String, SoCTj As String, TKNo As String, TKCo As String
With Sheet1
       eRow = .[B65000].End(xlUp).Row
       .Range("K2:U1000").ClearContents
        j = 2
        For i = 2 To eRow
            SoCT = .Range("A" & i)
            SoCTj = .Range("A" & i + 1)
            SoTien = .Range("A" & i).Offset(, 8) + SoTien
            If .Range("A" & i).Offset(, 1) <> .Range("A" & i - 1).Offset(, 1) Then
                SoHD = .Range("A" & i).Offset(, 1) & "; " & SoHD
            End If
            Select Case Left(SoCT, 2)
                Case "PC"
                    TKCo = "1111"
                    TKNoX = .Range("A" & i).Offset(, 6)
                    If InStr(TKNo, TKNoX) > 0 Then
                        TKNo = TKNo
                    Else
                        TKNo = TKNoX & "; " & TKNo
                    End If
                Case "PT"
                    TKNo = "1111"
                    TKCoX = .Range("A" & i).Offset(, 7)
                    If InStr(TKCo, TKCoX) > 0 Then
                        TKCo = TKCo
                    Else
                        TKCo = TKCoX & "; " & TKCo
                    End If
            End Select
            If SoCT <> SoCTj Then
                .Range("K" & j) = SoCT
                .Range("K" & j).Offset(, 1) = .Range("A" & i).Offset(, 2) 'Ngayht
                .Range("K" & j).Offset(, 2) = .Range("A" & i).Offset(, 4) 'NoiDung
                .Range("K" & j).Offset(, 3) = .Range("A" & i).Offset(, 5) 'DienGiai
                .Range("K" & j).Offset(, 6) = SoTien
                 SoHD = Left(SoHD, Len(SoHD) - 2)
                 TKNo = IIf(Right(TKNo, 2) = "; ", Left(TKNo, Len(TKNo) - 2), TKNo)
                 TKCo = IIf(Right(TKCo, 2) = "; ", Left(TKCo, Len(TKCo) - 2), TKCo)
                 .Range("K" & j).Offset(, 7) = SoHD
                 .Range("K" & j).Offset(, 4) = TKNo
                 .Range("K" & j).Offset(, 5) = TKCo
                 SoHD = ""
                 TKNo = ""
                 TKCo = ""
                 SoTien = 0
                  j = j + 1
               
            End If
        Next
    End With
End Sub
Đúng rồi, cái TK đối ứng là chỉ lấy duy nhất thôi. Cái đọan lấy duy nhất (bold) vụng về quá. Nhờ các Bác sửa lại hộ.
Xem file kèm.
Nhờ Mod xóa hộ bài này, trùng.
 

File đính kèm

Upvote 0
PHP: 
Sub TaoSP()
Dim SoTien As Long, SoHD As String
Dim i As Long, j As Long, TKNoX As String, TKCoX As String
Dim SoCT As String, SoCTj As String, TKNo As String, TKCo As String
With Sheet1
       eRow = .[B65000].End(xlUp).Row
       .Range("K2:U1000").ClearContents
        j = 2
        For i = 2 To eRow
            SoCT = .Range("A" & i)
            SoCTj = .Range("A" & i + 1)
            SoTien = .Range("A" & i).Offset(, 8) + SoTien
            If .Range("A" & i).Offset(, 1) <> .Range("A" & i - 1).Offset(, 1) Then
                SoHD = .Range("A" & i).Offset(, 1) & "; " & SoHD
            End If
            Select Case Left(SoCT, 2)
                Case "PC"
                    TKCo = "1111"
                    TKNoX = .Range("A" & i).Offset(, 6)
                    If InStr(TKNo, TKNoX) > 0 Then
                        TKNo = TKNo
                    Else
                        TKNo = TKNoX & "; " & TKNo
                    End If
                Case "PT"
                    TKNo = "1111"
                    TKCoX = .Range("A" & i).Offset(, 7)
                    If InStr(TKCo, TKCoX) > 0 Then
                        TKCo = TKCo
                    Else
                        TKCo = TKCoX & "; " & TKCo
                    End If
            End Select
            If SoCT <> SoCTj Then
                .Range("K" & j) = SoCT
                .Range("K" & j).Offset(, 1) = .Range("A" & i).Offset(, 2) 'Ngayht
                .Range("K" & j).Offset(, 2) = .Range("A" & i).Offset(, 4) 'NoiDung
                .Range("K" & j).Offset(, 3) = .Range("A" & i).Offset(, 5) 'DienGiai
                .Range("K" & j).Offset(, 6) = SoTien
                 SoHD = Left(SoHD, Len(SoHD) - 2)
                 TKNo = IIf(Right(TKNo, 2) = "; ", Left(TKNo, Len(TKNo) - 2), TKNo)
                 TKCo = IIf(Right(TKCo, 2) = "; ", Left(TKCo, Len(TKCo) - 2), TKCo)
                 .Range("K" & j).Offset(, 7) = SoHD
                 .Range("K" & j).Offset(, 4) = TKNo
                 .Range("K" & j).Offset(, 5) = TKCo
                 SoHD = ""
                 TKNo = ""
                 TKCo = ""
                 SoTien = 0
                  j = j + 1
               
            End If
        Next
    End With
End Sub
Đúng rồi, cái TK đối ứng là chỉ lấy duy nhất thôi. Cái đọan lấy duy nhất (If InStr(TKCo, TKCoX) > 0 Then) vụng về quá. Nhờ các Bác sửa lại hộ.
Xem file kèm.

To: Bác PTM
Bác nói oan cho em rồi, hết giờ em phải về đi nhậu. Với lại chưa test cẩn thận không dám phát biểu và em cũng có 1 hướng mới nên đưa lên tham khảo luôn. Cám ơn Bác nhiều. Bác test hộ em luôn!
 

File đính kèm

Upvote 0
Upvote 0
Bài này coi như Noidung và Diengiai của cùng 1 SoCt thì giống nhau như ví dụ của ThuNghi
Mã: 
Sub GomHoaDon()
Dim rcDt As Long, rcTC As Long, r As Long, rf As Long, rf1 As Long
Dim sotien As Double
Dim soCt As String
Dim soHd As String, tkCo As String
rcDt = Cells(Cells.Rows.Count, 1).End(xlUp).Row
rcTC = Cells(Cells.Rows.Count, 11).End(xlUp).Row
Range(Cells(4, 11), Cells(rcTC, 19)).ClearContents
Range(Cells(3, 1), Cells(rcDt, 1)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(3, 11), Unique:=True
rcTC = Cells(Cells.Rows.Count, 11).End(xlUp).Row
If rcTC >= 4 Then
  For r = 4 To rcTC
    soCt = Cells(r, 11)
    rf = 3: rf1 = 0
    sotien = 0:    tkCo = "": soHd = ""
    rf = Range(Cells(3, 1), Cells(rcDt, 1)).Find(What:=soCt, After:=Cells(3, 1)).Row
    For rf1 = rf To rcDt
      If InStr(1, soHd, Cells(rf1, 2)) = 0 Then soHd = soHd & Cells(rf1, 2) & ", "
      If InStr(1, tkCo, Cells(rf1, 8)) = 0 Then tkCo = tkCo & Cells(rf1, 8) & ", "
      sotien = sotien + Cells(rf1, 9)
      If Cells(rf1 + 1, 1) = "" Or Cells(rf1 + 1, 1) <> soCt Then Exit For
    Next
    Cells(r, 17) = Left(tkCo, Len(tkCo) - 2)
    Cells(r, 18) = sotien
    Cells(r, 19) = Left(soHd, Len(soHd) - 2)
    Cells(r, 12) = Cells(rf1, 3)
    Cells(r, 13) = Cells(rf1, 4)
    Cells(r, 14) = Cells(rf1, 5)
    Cells(r, 15) = Cells(rf1, 6)
    Cells(r, 16) = Cells(rf1, 7)
  Next
End If
End Sub
 

File đính kèm

Upvote 0
ptm0412 đã viết:
2. Sub và UDF của MrOkeBab: Kết quả đúng 100%, nhưng mới chỉ làm có 1 cột liệt kê hoá đơn :)
Nhấp chuột vào đây để mở rộng...

Em lại không để ý cái vụ tài khoản, rồi cộng dồn lại, cứ tưởng chỉ có hóa đơn.
Vì vậy làm UDF khó khăn hơn.

Thôi đành làm SUB vậy :

PHP: 
Sub ThuNghi()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim i As Long, iOB As Long, HC As Long
    Dim Ma As String, HD As String
    iOB = 1: HC = 1
    OB.Range("A2:I10000").ClearContents
    With TN
        For i = 2 To .Range("A65000").End(xlUp).Row
            Ma = .Range("A" & i).Value
            iOB = TimRow(Ma, OB.Range("A1:A" & HC))
            If iOB = 0 Then
                HC = HC + 1
                iOB = HC
                OB.Range("A" & iOB).Value = Ma
                OB.Range("B" & iOB & ":H" & iOB).Value = .Range("C" & i & ":I" & i).Value
                OB.Range("I" & iOB).Value = "_" & .Range("B" & i).Text
            Else
                If InStr(1, OB.Range("F" & iOB), .Range("G" & i)) = 0 Then _
                    OB.Range("F" & iOB) = OB.Range("F" & iOB).Text & "; " & .Range("G" & i).Text
                If InStr(1, OB.Range("G" & iOB), .Range("H" & i)) = 0 Then _
                    OB.Range("G" & iOB) = OB.Range("G" & iOB).Text & "; " & .Range("H" & i).Text
                OB.Range("H" & iOB).Value = OB.Range("H" & iOB).Value + .Range("I" & i).Value
                If InStr(1, OB.Range("I" & iOB), .Range("B" & i)) = 0 Then _
                    OB.Range("I" & iOB) = OB.Range("I" & iOB).Text & "; " & .Range("B" & i).Text
            End If
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


PHP: 
Function TimRow(Ma As String, Mang As Range) As Long
    On Error Resume Next
    TimRow = WorksheetFunction.Match(Ma, Mang, 0)
End Function



SoCT|SoHD|NgayHT|NgayCT|NoiDung|DienGiai|TKNo|TKCo|SoTien
PT07/061|0062523|31-07-08|31-07-08|KH 01|Mat hang 01|1111|511|9.500.000
PT07/061|0062523|31-07-08|31-07-08|KH 01|Mat hang 01|1111|33311|475.000
PT07/062|0062524|31-07-08|31-07-08|KH02|Mat hang 02|1111|511|123.000.000
PT07/062|0062524|31-07-08|31-07-08|KH02|Mat hang 02|1111|33311|6.150.000
PT07/062|0062525|31-07-08|31-07-08|KH02|Mat hang 02|1111|511|105.700.000
PT07/062|0062525|31-07-08|31-07-08|KH02|Mat hang 02|1111|33311|5.285.000
PC07/061|0062523|01-08-08|01-08-08|KH 01|Mat hang 01|511|1111|9.500.000
PC07/061|0062523|01-08-08|01-08-08|KH 01|Mat hang 01|33311|1111|475.000
PC07/062|0062524|01-08-08|01-08-08|KH02|Mat hang 02|511|1111|123.000.000
PC07/062|0062524|01-08-08|01-08-08|KH02|Mat hang 02|33311|1111|6.150.000
PC07/062|0062525|01-08-08|01-08-08|KH02|Mat hang 02|511|1111|105.700.000
PC07/062|0062525|01-08-08|01-08-08|KH02|Mat hang 02|33311|1111|5.285.000

Kết quả :

SoCT|NgayHT|NgayCT|NoiDung|DienGiai|TKNo|TKCo|SoTien|SoHD
PT07/061|31-07-2008|31-07-2008|KH 01|Mat hang 01|1111|511; 33311|9.975.000|_0062523
PT07/062|31-07-2008|31-07-2008|KH02|Mat hang 02|1111|511; 33311|240.135.000|_0062524; 0062525
PC07/061|01-08-2008|01-08-2008|KH 01|Mat hang 01|511; 33311|1111|9.975.000|_0062523
PC07/062|01-08-2008|01-08-2008|KH02|Mat hang 02|511; 33311|1111|240.135.000|_0062524; 0062525
 

File đính kèm

Upvote 0
Cám ơn các anh nhiều, tôi đã làm được rồi. Lấy 1 code 1 chút. Do sơ sót nên quên nói là dữ liệu đã được sort theo SoCT, NgayHT, Sohd nên công đọan AD không cần lắm. Cứ for i nếu SoHD khác là thì lấy SoHD khác.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

HeSanbi
  • Đã giải quyết
LocalizeXL v1.71 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3
Trả lời
58
Đọc
9K
HeSanbi
HeSanbi
vanle33
File không thao tác gì khi mở ra vẫn hỏi lưu lại khi tắt đi.
Trả lời
5
Đọc
56
zzzsxxx01
Z
N
Cách đánh số thứ tự không liên tục (đánh số lại từ đầu khi cột bên cạnh có giá trị)
Trả lời
0
Đọc
22
ngodinhhoang
N
G
Chuyển Data từ hàng và cột về dạng cột
Trả lời
10
Đọc
130
VetMini
V
linhvu2807
Lỗi hàm công thức Querry
Trả lời
0
Đọc
28
linhvu2807
linhvu2807
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
    • Yêu thích
Trả lời
15
Đọc
2K
Võ Việt Tuyến
V
C
Tìm dữ liệu khác nhau trong 2 file hoặc 2 sheet trong excel
Trả lời
2
Đọc
114
HUONGHCKT
H
D
Paste dữ liệu, bỏ qua các cell ẩn
2
Trả lời
30
Đọc
45K
HUONGHCKT
H
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
3
Đọc
135
yaaasoo01
Y
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
0
Đọc
473
GPE-Trợ Lý
GPE-Trợ Lý
B
Xin hàm đếm số lượng khách hàng theo 1 điều kiện và bỏ dữ liệu trùng.
Trả lời
11
Đọc
455
bipbo2008
B
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
2
Đọc
228
HeSanbi
HeSanbi
NguyenthiH
Sao dùng Ctl + H thay thế không đúng.
Trả lời
19
Đọc
255
NguyenthiH
NguyenthiH
N
Lỗi định dạng số Excel 2019 - Nguyên nhân và cách khắc phục
Trả lời
1
Đọc
42
ptm0412
ptm0412
huuthang_bd
Chia sẻ: Tạo thông báo nhắc nhở khi sắp đến ngày kỷ niệm
    • Thích
    • Yêu thích
2
Trả lời
39
Đọc
9K
ngocminhkte
ngocminhkte
P
Tại sao khi đánh số thì bị mất hai số cuối
Trả lời
3
Đọc
18K
Nguyenlong2608
N
HeSanbi
  • Đã giải quyết
ExcelController - Các hàm thực thi tác vụ linh hoạt cho Excel
    • Thích
    • Yêu thích
Trả lời
5
Đọc
1K
HeSanbi
HeSanbi
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
10
Đọc
241
HUONGHCKT
H
V
Xin giúp em file theo dõi thanh toán có bị quá hạn không, quá bao nhiêu ngày và bao nhiêu tiền ạ
Trả lời
10
Đọc
239
hvnhpro
H
tuv8x
Xin hỏi cách giới hạn vùng làm việc
Trả lời
2
Đọc
90
tuv8x
tuv8x
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom