Chuyển đổi bảng dữ liệu sang dạng mong muốn

vanvan9697 · 26/7/19

Em chào anh (chị) Diễn đàn Giaiphapexcel.com.vn. Em có một vấn sau mong muốn anh ( chị) trên diễn đàn giúp em ạ
Em Có sử dụng đoạn code trên để chuyển vùng dữ liệu từ A2:E Với kết quả mong muốn là vùng Dữ liệu từ H2: M với những điều kiện như sau:
Nếu trong cùng 1 tháng và cùng Mã thì sẽ được chuyển dữ liệu từ dạng 1 cột TK và 1 cột TK đối ứng sang 1 cột tài khoản và 2 cột Số tiền nợ và Số tiền có
Cột số thứ tự được đánh theo liên tiếp với điều kiện
Tuy nhiên code trên vẫn chưa chuyển đúng ạ !, em mong anh (chị) sửa giúp em ạ
Em Cảm ơn anh ( chị) trên diễn đàn đã giúp đỡ em ạ !

Mã:

Sub ChenDongThem()
Dim Arr(), ArrPhanTich(), Dic As Object
Dim  J As Long, W As Long
Dim StrC As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    ArrPhanTich = .Range("A2:e" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
ReDim Arr(1 To UBound(ArrPhanTich, 1) * 3, 1 To 4)
For J = 1 To UBound(ArrPhanTich, 1)
    StrC = ArrPhanTich(J, 1) & "#" & ArrPhanTich(J, 4)
    If Not Dic.exists(StrC) Then
        W = W + 2
        Dic.Add StrC, W
        Arr(W, 1) = ArrPhanTich(J, 1)
        Arr(W, 2) = ArrPhanTich(J, 2)
        Arr(W, 3) = Arr(W, 3) + ArrPhanTich(J, 3)
        Arr(W, 4) = Arr(W, 4)
    Else
        W = W + 1
        Arr(W, 1) = ArrPhanTich(J, 1)
        Arr(W, 2) = ArrPhanTich(J, 2)
        Arr(W, 3) = Arr(W, 3) + ArrPhanTich(J, 3)
        Arr(W, 4) = Arr(W, 4)
    End If
Next J
Sheet1.Range("02").Resize(W, 4).Value = Arr()     '!!!'

End Sub

HieuCD · 28/7/19

vanvan9697 đã viết:
Em chào anh (chị) Diễn đàn Giaiphapexcel.com.vn. Em có một vấn sau mong muốn anh ( chị) trên diễn đàn giúp em ạ
Em Có sử dụng đoạn code trên để chuyển vùng dữ liệu từ A2:E Với kết quả mong muốn là vùng Dữ liệu từ H2: M với những điều kiện như sau:
Nếu trong cùng 1 tháng và cùng Mã thì sẽ được chuyển dữ liệu từ dạng 1 cột TK và 1 cột TK đối ứng sang 1 cột tài khoản và 2 cột Số tiền nợ và Số tiền có
Cột số thứ tự được đánh theo liên tiếp với điều kiện
Tuy nhiên code trên vẫn chưa chuyển đúng ạ !, em mong anh (chị) sửa giúp em ạ
Em Cảm ơn anh ( chị) trên diễn đàn đã giúp đỡ em ạ !

Mã:

Sub ChenDongThem() Dim Arr(), ArrPhanTich(), Dic As Object Dim J As Long, W As Long Dim StrC As String Set Dic = CreateObject("Scripting.Dictionary") With Sheet1 ArrPhanTich = .Range("A2:e" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value End With ReDim Arr(1 To UBound(ArrPhanTich, 1) * 3, 1 To 4) For J = 1 To UBound(ArrPhanTich, 1) StrC = ArrPhanTich(J, 1) & "#" & ArrPhanTich(J, 4) If Not Dic.exists(StrC) Then W = W + 2 Dic.Add StrC, W Arr(W, 1) = ArrPhanTich(J, 1) Arr(W, 2) = ArrPhanTich(J, 2) Arr(W, 3) = Arr(W, 3) + ArrPhanTich(J, 3) Arr(W, 4) = Arr(W, 4) Else W = W + 1 Arr(W, 1) = ArrPhanTich(J, 1) Arr(W, 2) = ArrPhanTich(J, 2) Arr(W, 3) = Arr(W, 3) + ArrPhanTich(J, 3) Arr(W, 4) = Arr(W, 4) End If Next J Sheet1.Range("02").Resize(W, 4).Value = Arr() '!!!' End Sub

Làm sao biết TK nơ, TK có?

vanvan9697 · 28/7/19

Dạ với số tiền ( cột C ) < 0 thì cột TK Nợ là cột B. Cột Tk có là Cột E.
Nếu số tiền ( Cột C) >0 thì cột tK nợ là cột E và cột TK có là cột B anh @HieuCD ạ

HieuCD · 28/7/19

vanvan9697 đã viết:
Dạ với số tiền ( cột C ) < 0 thì cột TK Nợ là cột B. Cột Tk có là Cột E.
Nếu số tiền ( Cột C) >0 thì cột tK nợ là cột E và cột TK có là cột B anh @HieuCD ạ

Kết quả giống y cột H:M ? hay theo lời giải thích

vanvan9697 · 29/7/19

HieuCD đã viết:
Kết quả giống y cột H:M ? hay theo lời giải thích

Dạ kết quả như cột H:M kèm lời giải thích anh ạ

ongke0711 · 29/7/19

Bài này thì tôi chỉ biết dùng ADO + Union query.

Mã:

Private Sub cmdThiHanh_Click()
    Dim rs As Object
    Dim sSQL As String, rRngName As String

    If ConnectDB = False Then
        MsgBox "Có loi ket noi du lieu", vbCritical, "Loi ket noi"
        Exit Sub
    End If

    rRngName = "tblSource"

    Set rs = CreateObject("ADODB.Recordset")

    sSQL = "SELECT A.Thang, A.TKDU AS TK, Sum(A.SoTien) AS PSNo, Sum(0) AS PSCo, A.Ma, A.TKDU FROM [" & rRngName & "] A " & _
           "GROUP BY A.Thang, A.Ma, A.TKDU " & _
           "Union ALL " & _
           "SELECT B.Thang, B.TK,Sum(0) AS PSNo, Sum(B.SoTien) AS PSCo, B.Ma, B.TKDU FROM [" & rRngName & "] B " & _
           "GROUP BY B.Thang, B.TK, B.Ma, B.TKDU " & _
           "ORDER By [Thang],[TKDU],[Ma],[TK]"

    Set rs = oCnn.Execute(sSQL)

    Sheet1.Range("G2").CopyFromRecordset rs

    rs.Close
    Set rs = Nothing
End Sub

Link demo: http://www.mediafire.com/file/6dh71kziy7chwdp/KetChuyenTKDU.xlsm/file

SA_DQ · 29/7/19

Bạn lảm ngành kế toán mà chuyện chính xác không nêu làm đầu thì có ngày đi tù à nha!
Ví dụ ư, xin đây

Nếu trong cùng 1 tháng và cùng Mã thì sẽ được chuyển dữ liệu từ dạng 1 cột TK và 1 cột TK đối ứng sang 1 cột tài khoản và 2 cột Số tiền nợ và Số tiền có

Nhưng các tiêu đề của bảng kết quả làm gì có [Số tiền nợ], mà nó là [Số tiền tổng] Viết như vậy thì chỉ những người trong ngành may ra hiểu thôi.
Những người khác lơ mơ sẽ "bỏ" file ngay tức khắc.
Ông bài xưa nói "Sai con toán bán con trâu", bạn thấy đúng không?

Làm sao biết TK nơ, TK có?
Dạ với số tiền ( cột C ) < 0 thì cột TK Nợ là cột B. Cột Tk có là Cột E.
Nếu số tiền ( Cột C) >0 thì cột tK nợ là cột E và cột TK có là cột B đó anh

Sao chuyện này bạn lại không nêu từ đầu; Chuyện này chứng tỏ bạn chỉ nhờ những người trong ngành được mà thôi.
& trong macro của bạn cũng chưa biểu hiện gì của điều kiện này.

(*) Sau mảng dùng để ghi kết quả bạn khai báo có 4 cột, Lí ra bạn cần khai báo 6 hay 7 cột; Những cột phía sau để nghi những cần thiết cho việc kiểm tra tính đúng đắc của 4 cột số liệu đầu. 1 khi chúng chính xác rồi ta xóa những cột phụ trợ cũng không muộn mà.
Bạn hãy tự kiểm lại & sửa đứa con tinh thần của mình đi; Người khác giúp bạn là hại bạn 1 chút nào đó trong việc rèn luyện tính cách đó!

vanvan9697 · 29/7/19

SA_DQ đã viết:
Bạn lảm ngành kế toán mà chuyện chính xác không nêu làm đầu thì có ngày đi tù à nha!
Ví dụ ư, xin đây

Nhưng các tiêu đề của bảng kết quả làm gì có [Số tiền nợ], mà nó là [Số tiền tổng] Viết như vậy thì chỉ những người trong ngành may ra hiểu thôi.
Những người khác lơ mơ sẽ "bỏ" file ngay tức khắc.
Ông bài xưa nói "Sai con toán bán con trâu", bạn thấy đúng không?

Sao chuyện này bạn lại không nêu từ đầu; Chuyện này chứng tỏ bạn chỉ nhờ những người trong ngành được mà thôi.
& trong macro của bạn cũng chưa biểu hiện gì của điều kiện này.

(*) Sau mảng dùng để ghi kết quả bạn khai báo có 4 cột, Lí ra bạn cần khai báo 6 hay 7 cột; Những cột phía sau để nghi những cần thiết cho việc kiểm tra tính đúng đắc của 4 cột số liệu đầu. 1 khi chúng chính xác rồi ta xóa những cột phụ trợ cũng không muộn mà.
Bạn hãy tự kiểm lại & sửa đứa con tinh thần của mình đi; Người khác giúp bạn là hại bạn 1 chút nào đó trong việc rèn luyện tính cách đó!

Dạ em cảm ơn bác ạ, bác có thể giúp em bài này dùng mảng và từ điển không ạ !

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

ongke0711 đã viết:

Bài này thì tôi chỉ biết dùng ADO + Union query.

Mã:

Private Sub cmdThiHanh_Click()
    Dim rs As Object
    Dim sSQL As String, rRngName As String

    If ConnectDB = False Then
        MsgBox "Có loi ket noi du lieu", vbCritical, "Loi ket noi"
        Exit Sub
    End If

    rRngName = "tblSource"

    Set rs = CreateObject("ADODB.Recordset")

    sSQL = "SELECT A.Thang, A.TKDU AS TK, Sum(A.SoTien) AS PSNo, Sum(0) AS PSCo, A.Ma, A.TKDU FROM [" & rRngName & "] A " & _
           "GROUP BY A.Thang, A.Ma, A.TKDU " & _
           "Union ALL " & _
           "SELECT B.Thang, B.TK,Sum(0) AS PSNo, Sum(B.SoTien) AS PSCo, B.Ma, B.TKDU FROM [" & rRngName & "] B " & _
           "GROUP BY B.Thang, B.TK, B.Ma, B.TKDU " & _
           "ORDER By [Thang],[TKDU],[Ma],[TK]"

    Set rs = oCnn.Execute(sSQL)

    Sheet1.Range("G2").CopyFromRecordset rs

    rs.Close
    Set rs = Nothing
End Sub

Link demo: http://www.mediafire.com/file/6dh71kziy7chwdp/KetChuyenTKDU.xlsm/file

View attachment 221905

Dạ vâng em cảm ơn anh nhiều ạ, kết quả đúng ý em rồi ạ

SA_DQ · 29/7/19

PHP:

Sub ChenDongThem()
 Dim Arr(), ArrFT(), Dict As Object:                    Dim StrC As String
 Dim Tong As Double, J As Long, W As Long
 
 Set Dict = CreateObject("Scripting.Dictionary")
 With Sheet1
    ArrFT() = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
 End With
 ReDim Arr(1 To 3 * UBound(ArrFT(), 1), 1 To 4)     ' Nên Khai Báo Tang Lên Thành 6 Cot  '
 For J = 1 To UBound(ArrFT(), 1)
    StrC = ArrFT(J, 1) & "#" & ArrFT(J, 4)
    If Not Dict.exists(StrC) Then
        W = W + 2:                                           Dict.Add StrC, W   ' Sao W lai phai Tang Môi Lân Là 2    ? '
        Arr(W, 1) = ArrFT(J, 1)
'Thêm Dòng Lênh Diêu Kiên Dê Gán Dúng Côt Theo Yêu Câu     '
        Arr(W, 2) = ArrFT(J, 2)
        Arr(W, 3) = Arr(W, 3) + ArrFT(J, 3):        Arr(W, 4) = Arr(W, 4)
' & Gán Vô Arr(w, 5) Dê Kiêm Tra Sô Liêu Dã Gán Dúng Chua?  '
    Else
        W = W + 1               'Sao W lai phai Tang?  '
        Arr(W, 1) = ArrFT(J, 1)
'Thêm D/K Nhu Trên      '
        Arr(W, 2) = ArrFT(J, 2)
        Arr(W, 3) = Arr(W, 3) + ArrFT(J, 3)
        Arr(W, 4) = Arr(W, 4)
'Nhu Trên Dã Nêu        '
    End If
 Next J
Sheet1.Range("02").Resize(W, 4).Value = Arr()     '!!!'
End Sub

vanvan9697 · 29/7/19

SA_DQ đã viết:

PHP:

Sub ChenDongThem()
Dim Arr(), ArrFT(), Dict As Object:                    Dim StrC As String
Dim Tong As Double, J As Long, W As Long

Set Dict = CreateObject("Scripting.Dictionary")
With Sheet1
    ArrFT() = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
ReDim Arr(1 To 3 * UBound(ArrFT(), 1), 1 To 4)     ' Nên Khai Báo Tang Lên Thành 6 Cot  '
For J = 1 To UBound(ArrFT(), 1)
    StrC = ArrFT(J, 1) & "#" & ArrFT(J, 4)
    If Not Dict.exists(StrC) Then
        W = W + 2:                                           Dict.Add StrC, W   ' Sao W lai phai Tang Môi Lân Là 2    ? '
        Arr(W, 1) = ArrFT(J, 1)
'Thêm Dòng Lênh Diêu Kiên Dê Gán Dúng Côt Theo Yêu Câu     '
        Arr(W, 2) = ArrFT(J, 2)
        Arr(W, 3) = Arr(W, 3) + ArrFT(J, 3):        Arr(W, 4) = Arr(W, 4)
' & Gán Vô Arr(w, 5) Dê Kiêm Tra Sô Liêu Dã Gán Dúng Chua?  '
    Else
        W = W + 1               'Sao W lai phai Tang?  '
        Arr(W, 1) = ArrFT(J, 1)
'Thêm D/K Nhu Trên      '
        Arr(W, 2) = ArrFT(J, 2)
        Arr(W, 3) = Arr(W, 3) + ArrFT(J, 3)
        Arr(W, 4) = Arr(W, 4)
'Nhu Trên Dã Nêu        '
    End If
Next J
Sheet1.Range("02").Resize(W, 4).Value = Arr()     '!!!'
End Sub

Em Tăng mỗi dòng lên 2 để có thể điền được cột TK DU ( cột E) vào thầy ạ !
Còn 'Thêm Dòng Lênh Diêu Kiên Dê Gán Dúng Côt Theo Yêu Câu thì em chưa nghĩa ra là thêm kiểu nào thầy ạ !

HieuCD · 29/7/19

vanvan9697 đã viết:
Em chào anh (chị) Diễn đàn Giaiphapexcel.com.vn. Em có một vấn sau mong muốn anh ( chị) trên diễn đàn giúp em ạ
Em Có sử dụng đoạn code trên để chuyển vùng dữ liệu từ A2:E Với kết quả mong muốn là vùng Dữ liệu từ H2: M với những điều kiện như sau:
Nếu trong cùng 1 tháng và cùng Mã thì sẽ được chuyển dữ liệu từ dạng 1 cột TK và 1 cột TK đối ứng sang 1 cột tài khoản và 2 cột Số tiền nợ và Số tiền có
Cột số thứ tự được đánh theo liên tiếp với điều kiện
Tuy nhiên code trên vẫn chưa chuyển đúng ạ !, em mong anh (chị) sửa giúp em ạ
Em Cảm ơn anh ( chị) trên diễn đàn đã giúp đỡ em ạ !

Mã:

Sub ChenDongThem() Dim Arr(), ArrPhanTich(), Dic As Object Dim J As Long, W As Long Dim StrC As String Set Dic = CreateObject("Scripting.Dictionary") With Sheet1 ArrPhanTich = .Range("A2:e" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value End With ReDim Arr(1 To UBound(ArrPhanTich, 1) * 3, 1 To 4) For J = 1 To UBound(ArrPhanTich, 1) StrC = ArrPhanTich(J, 1) & "#" & ArrPhanTich(J, 4) If Not Dic.exists(StrC) Then W = W + 2 Dic.Add StrC, W Arr(W, 1) = ArrPhanTich(J, 1) Arr(W, 2) = ArrPhanTich(J, 2) Arr(W, 3) = Arr(W, 3) + ArrPhanTich(J, 3) Arr(W, 4) = Arr(W, 4) Else W = W + 1 Arr(W, 1) = ArrPhanTich(J, 1) Arr(W, 2) = ArrPhanTich(J, 2) Arr(W, 3) = Arr(W, 3) + ArrPhanTich(J, 3) Arr(W, 4) = Arr(W, 4) End If Next J Sheet1.Range("02").Resize(W, 4).Value = Arr() '!!!' End Sub

Code khá rối, chạy Sub Main

Mã:

Dim sArr(), Arr(), Res(), stt As Long, n As Long
Sub Main()
  Dim Dic As Object, iKey As String, tmp As String, TKno As String, TKco As String
  Dim i As Long, r As Long, stt As Long, k As Long, ik As Long, dau As Long
  n = 0: stt = 0
  With Sheet1
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  Call LocData
  Call KetQua
End Sub

Private Sub KetQua()
  Dim tmp, noBln As Boolean, iKey As String, TKdu As String
  Dim i As Long, j As Long, r As Long, k As Long, ik As Long, q As Long
  Dim C1 As Long, C2 As Long, TK1 As Long, TK2 As Long
 
  ReDim Res(1 To n * 2, 1 To 6)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To stt
      tmp = Arr(i)
      If tmp(0) < tmp(1) Then noBln = True Else noBln = False
      For j = 2 To UBound(tmp)
        ik = tmp(j)
        If noBln Then
          TK1 = 2: TK2 = 5
          C1 = 3: C2 = 4
        Else
          TK1 = 5: TK2 = 2
          C1 = 4: C2 = 3
        End If
        iKey = sArr(ik, TK1)
        If Not .exists(iKey) Then
          k = k + 1
          .Add iKey, ""
          ID = k
          Res(k, 1) = sArr(ik, 1)
          Res(k, 2) = iKey
          Res(k, 5) = i
          Res(k, 6) = sArr(ik, 4)
          For r = j To UBound(tmp)
            q = tmp(r)
            If iKey = sArr(q, TK1) Then
              k = k + 1
              Res(k, 1) = sArr(q, 1)
              Res(k, 2) = sArr(q, TK2)
              Res(k, C2) = sArr(q, 3)
              Res(k, 5) = i
              Res(k, 6) = sArr(q, 4)
              Res(ID, C1) = Res(ID, C1) + sArr(q, 3)
            End If
          Next r
        End If
      Next j
      .RemoveAll
    Next i
  End With
  Sheet1.Range("H2").Resize(k, 6).Value = Res
End Sub

Private Sub LocData()
  Dim tmp
  Dim iKey As String, nKey As String, TKno As String, TKco As String
  Dim sRow As Long, i As Long, tt As Long, ik As Long, dau As Long
 
  With CreateObject("Scripting.Dictionary")
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      If sArr(i, 3) <> 0 Then
        iKey = sArr(i, 1) & "#" & sArr(i, 4)
        If Not .exists(iKey) Then
          stt = stt + 1
          .Add iKey, stt
          ReDim Preserve Arr(1 To stt)
          Arr(stt) = Array(0, 0)
        End If
        tt = .Item(iKey)
        If sArr(i, 3) > 0 Then
          TKno = sArr(i, 5): TKco = sArr(i, 2): dau = 1
        Else
          TKno = sArr(i, 2): TKco = sArr(i, 5): dau = -1
        End If
        nKey = iKey & "N" & TKno & "C" & TKco
        If Not .exists(nKey) Then
          n = n + 1
          .Add nKey, n
          sArr(n, 1) = sArr(i, 1)
          sArr(n, 2) = TKno
          sArr(n, 3) = sArr(i, 3) * dau
          sArr(n, 4) = sArr(i, 4)
          sArr(n, 5) = TKco
          sArr(n, 6) = tt
          tmp = Arr(tt)
          ReDim Preserve tmp(0 To UBound(tmp) + 1)
          tmp(UBound(tmp)) = n
          Arr(tt) = tmp
        Else
          ik = .Item(nKey)
          sArr(ik, 3) = sArr(ik, 3) + sArr(i, 3) * dau
        End If
        nKey = iKey & "N" & TKno
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(0) = tmp(0) + 1
          Arr(tt) = tmp
        End If
        nKey = iKey & "C" & TKco
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(1) = tmp(1) + 1
          Arr(tt) = tmp
        End If
      End If
    Next i
  End With
End Sub

vanvan9697 · 29/7/19

HieuCD đã viết:

Code khá rối, chạy Sub Main

Mã:

Dim sArr(), Arr(), Res(), stt As Long, n As Long
Sub Main()
  Dim Dic As Object, iKey As String, tmp As String, TKno As String, TKco As String
  Dim i As Long, r As Long, stt As Long, k As Long, ik As Long, dau As Long
  n = 0: stt = 0
  With Sheet1
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  Call LocData
  Call KetQua
End Sub

Private Sub KetQua()
  Dim tmp, noBln As Boolean, iKey As String, TKdu As String
  Dim i As Long, j As Long, r As Long, k As Long, ik As Long, q As Long
  Dim C1 As Long, C2 As Long, TK1 As Long, TK2 As Long

  ReDim Res(1 To n * 2, 1 To 6)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To stt
      tmp = Arr(i)
      If tmp(0) < tmp(1) Then noBln = True Else noBln = False
      For j = 2 To UBound(tmp)
        ik = tmp(j)
        If noBln Then
          TK1 = 2: TK2 = 5
          C1 = 3: C2 = 4
        Else
          TK1 = 5: TK2 = 2
          C1 = 4: C2 = 3
        End If
        iKey = sArr(ik, TK1)
        If Not .exists(iKey) Then
          k = k + 1
          .Add iKey, ""
          ID = k
          Res(k, 1) = sArr(ik, 1)
          Res(k, 2) = iKey
          Res(k, 5) = i
          Res(k, 6) = sArr(ik, 4)
          For r = j To UBound(tmp)
            q = tmp(r)
            If iKey = sArr(q, TK1) Then
              k = k + 1
              Res(k, 1) = sArr(q, 1)
              Res(k, 2) = sArr(q, TK2)
              Res(k, C2) = sArr(q, 3)
              Res(k, 5) = i
              Res(k, 6) = sArr(q, 4)
              Res(ID, C1) = Res(ID, C1) + sArr(q, 3)
            End If
          Next r
        End If
      Next j
      .RemoveAll
    Next i
  End With
  Sheet1.Range("H2").Resize(k, 6).Value = Res
End Sub

Private Sub LocData()
  Dim tmp
  Dim iKey As String, nKey As String, TKno As String, TKco As String
  Dim sRow As Long, i As Long, tt As Long, ik As Long, dau As Long

  With CreateObject("Scripting.Dictionary")
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      If sArr(i, 3) <> 0 Then
        iKey = sArr(i, 1) & "#" & sArr(i, 4)
        If Not .exists(iKey) Then
          stt = stt + 1
          .Add iKey, stt
          ReDim Preserve Arr(1 To stt)
          Arr(stt) = Array(0, 0)
        End If
        tt = .Item(iKey)
        If sArr(i, 3) > 0 Then
          TKno = sArr(i, 5): TKco = sArr(i, 2): dau = 1
        Else
          TKno = sArr(i, 2): TKco = sArr(i, 5): dau = -1
        End If
        nKey = iKey & "N" & TKno & "C" & TKco
        If Not .exists(nKey) Then
          n = n + 1
          .Add nKey, n
          sArr(n, 1) = sArr(i, 1)
          sArr(n, 2) = TKno
          sArr(n, 3) = sArr(i, 3) * dau
          sArr(n, 4) = sArr(i, 4)
          sArr(n, 5) = TKco
          sArr(n, 6) = tt
          tmp = Arr(tt)
          ReDim Preserve tmp(0 To UBound(tmp) + 1)
          tmp(UBound(tmp)) = n
          Arr(tt) = tmp
        Else
          ik = .Item(nKey)
          sArr(ik, 3) = sArr(ik, 3) + sArr(i, 3) * dau
        End If
        nKey = iKey & "N" & TKno
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(0) = tmp(0) + 1
          Arr(tt) = tmp
        End If
        nKey = iKey & "C" & TKco
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(1) = tmp(1) + 1
          Arr(tt) = tmp
        End If
      End If
    Next i
  End With
End Sub

Dạ Vâng em cảm ơn anh Hiếu nhiều ạ !

HieuCD · 29/7/19

vanvan9697 đã viết:
Dạ Vâng em cảm ơn anh Hiếu nhiều ạ !

Đánh STT theo tháng

Mã:

Dim sArr(), Arr(), Res(), stt As Long, n As Long
Sub Main()
  Dim Dic As Object, iKey As String, tmp As String, TKno As String, TKco As String
  Dim i As Long, r As Long, stt As Long, k As Long, ik As Long, dau As Long
 
  With Sheet1
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  Call LocData
  Call KetQua
  Erase sArr: Erase Arr: Erase Res
End Sub

Private Sub KetQua()
  Dim tmp, noBln As Boolean, iKey As String, TKdu As String
  Dim i As Long, j As Long, r As Long, k As Long, ik As Long, q As Long
  Dim C1 As Long, C2 As Long, TK1 As Long, TK2 As Long
  Dim Thang As Long, t As Long

  ReDim Res(1 To n * 2, 1 To 6)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To stt
      tmp = Arr(i)
      If tmp(0) < tmp(1) Then noBln = True Else noBln = False
      For j = 2 To UBound(tmp)
        ik = tmp(j)
        If noBln Then
          TK1 = 2: TK2 = 5
          C1 = 3: C2 = 4
        Else
          TK1 = 5: TK2 = 2
          C1 = 4: C2 = 3
        End If
        iKey = sArr(ik, TK1)
        If Not .exists(iKey) Then
          k = k + 1
          .Add iKey, ""
          ID = k
          
          Res(k, 1) = sArr(ik, 1)
          Res(k, 2) = iKey
          
          If Thang <> Res(k, 1) Then
            Thang = Res(k, 1)
            t = 1
          Else
            t = t + 1
          End If
          Res(k, 5) = t
          Res(k, 6) = sArr(ik, 4)
          For r = j To UBound(tmp)
            q = tmp(r)
            If iKey = sArr(q, TK1) Then
              k = k + 1
              Res(k, 1) = sArr(q, 1)
              Res(k, 2) = sArr(q, TK2)
              Res(k, C2) = sArr(q, 3)
              Res(k, 5) = t
              Res(k, 6) = sArr(q, 4)
              Res(ID, C1) = Res(ID, C1) + sArr(q, 3)
            End If
          Next r
        End If
      Next j
      .RemoveAll
    Next i
  End With
  Sheet1.Range("H2").Resize(k, 6).Value = Res
End Sub

Private Sub LocData()
  Dim tmp
  Dim iKey As String, nKey As String, TKno As String, TKco As String
  Dim sRow As Long, i As Long, tt As Long, ik As Long, dau As Long
 
  n = 0: stt = 0
  With CreateObject("Scripting.Dictionary")
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      If sArr(i, 3) <> 0 Then
        iKey = sArr(i, 1) & "#" & sArr(i, 4)
        If Not .exists(iKey) Then
          stt = stt + 1
          .Add iKey, stt
          ReDim Preserve Arr(1 To stt)
          Arr(stt) = Array(0, 0)
        End If
        tt = .Item(iKey)
        If sArr(i, 3) > 0 Then
          TKno = sArr(i, 5): TKco = sArr(i, 2): dau = 1
        Else
          TKno = sArr(i, 2): TKco = sArr(i, 5): dau = -1
        End If
        nKey = iKey & "N" & TKno & "C" & TKco
        If Not .exists(nKey) Then
          n = n + 1
          .Add nKey, n
          sArr(n, 1) = sArr(i, 1)
          sArr(n, 2) = TKno
          sArr(n, 3) = sArr(i, 3) * dau
          sArr(n, 4) = sArr(i, 4)
          sArr(n, 5) = TKco
          sArr(n, 6) = tt
          tmp = Arr(tt)
          ReDim Preserve tmp(0 To UBound(tmp) + 1)
          tmp(UBound(tmp)) = n
          Arr(tt) = tmp
        Else
          ik = .Item(nKey)
          sArr(ik, 3) = sArr(ik, 3) + sArr(i, 3) * dau
        End If
        nKey = iKey & "N" & TKno
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(0) = tmp(0) + 1
          Arr(tt) = tmp
        End If
        nKey = iKey & "C" & TKco
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(1) = tmp(1) + 1
          Arr(tt) = tmp
        End If
      End If
    Next i
  End With
End Sub

vanvan9697 · 30/7/19

HieuCD đã viết:

Code khá rối, chạy Sub Main

Mã:

Dim sArr(), Arr(), Res(), stt As Long, n As Long
Sub Main()
  Dim Dic As Object, iKey As String, tmp As String, TKno As String, TKco As String
  Dim i As Long, r As Long, stt As Long, k As Long, ik As Long, dau As Long
  n = 0: stt = 0
  With Sheet1
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  Call LocData
  Call KetQua
End Sub

Private Sub KetQua()
  Dim tmp, noBln As Boolean, iKey As String, TKdu As String
  Dim i As Long, j As Long, r As Long, k As Long, ik As Long, q As Long
  Dim C1 As Long, C2 As Long, TK1 As Long, TK2 As Long

  ReDim Res(1 To n * 2, 1 To 6)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To stt
      tmp = Arr(i)
      If tmp(0) < tmp(1) Then noBln = True Else noBln = False
      For j = 2 To UBound(tmp)
        ik = tmp(j)
        If noBln Then
          TK1 = 2: TK2 = 5
          C1 = 3: C2 = 4
        Else
          TK1 = 5: TK2 = 2
          C1 = 4: C2 = 3
        End If
        iKey = sArr(ik, TK1)
        If Not .exists(iKey) Then
          k = k + 1
          .Add iKey, ""
          ID = k
          Res(k, 1) = sArr(ik, 1)
          Res(k, 2) = iKey
          Res(k, 5) = i
          Res(k, 6) = sArr(ik, 4)
          For r = j To UBound(tmp)
            q = tmp(r)
            If iKey = sArr(q, TK1) Then
              k = k + 1
              Res(k, 1) = sArr(q, 1)
              Res(k, 2) = sArr(q, TK2)
              Res(k, C2) = sArr(q, 3)
              Res(k, 5) = i
              Res(k, 6) = sArr(q, 4)
              Res(ID, C1) = Res(ID, C1) + sArr(q, 3)
            End If
          Next r
        End If
      Next j
      .RemoveAll
    Next i
  End With
  Sheet1.Range("H2").Resize(k, 6).Value = Res
End Sub

Private Sub LocData()
  Dim tmp
  Dim iKey As String, nKey As String, TKno As String, TKco As String
  Dim sRow As Long, i As Long, tt As Long, ik As Long, dau As Long

  With CreateObject("Scripting.Dictionary")
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      If sArr(i, 3) <> 0 Then
        iKey = sArr(i, 1) & "#" & sArr(i, 4)
        If Not .exists(iKey) Then
          stt = stt + 1
          .Add iKey, stt
          ReDim Preserve Arr(1 To stt)
          Arr(stt) = Array(0, 0)
        End If
        tt = .Item(iKey)
        If sArr(i, 3) > 0 Then
          TKno = sArr(i, 5): TKco = sArr(i, 2): dau = 1
        Else
          TKno = sArr(i, 2): TKco = sArr(i, 5): dau = -1
        End If
        nKey = iKey & "N" & TKno & "C" & TKco
        If Not .exists(nKey) Then
          n = n + 1
          .Add nKey, n
          sArr(n, 1) = sArr(i, 1)
          sArr(n, 2) = TKno
          sArr(n, 3) = sArr(i, 3) * dau
          sArr(n, 4) = sArr(i, 4)
          sArr(n, 5) = TKco
          sArr(n, 6) = tt
          tmp = Arr(tt)
          ReDim Preserve tmp(0 To UBound(tmp) + 1)
          tmp(UBound(tmp)) = n
          Arr(tt) = tmp
        Else
          ik = .Item(nKey)
          sArr(ik, 3) = sArr(ik, 3) + sArr(i, 3) * dau
        End If
        nKey = iKey & "N" & TKno
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(0) = tmp(0) + 1
          Arr(tt) = tmp
        End If
        nKey = iKey & "C" & TKco
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(1) = tmp(1) + 1
          Arr(tt) = tmp
        End If
      End If
    Next i
  End With
End Sub

[/QU

HieuCD đã viết:

Đánh STT theo tháng

Mã:

Dim sArr(), Arr(), Res(), stt As Long, n As Long
Sub Main()
  Dim Dic As Object, iKey As String, tmp As String, TKno As String, TKco As String
  Dim i As Long, r As Long, stt As Long, k As Long, ik As Long, dau As Long

  With Sheet1
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  Call LocData
  Call KetQua
  Erase sArr: Erase Arr: Erase Res
End Sub

Private Sub KetQua()
  Dim tmp, noBln As Boolean, iKey As String, TKdu As String
  Dim i As Long, j As Long, r As Long, k As Long, ik As Long, q As Long
  Dim C1 As Long, C2 As Long, TK1 As Long, TK2 As Long
  Dim Thang As Long, t As Long

  ReDim Res(1 To n * 2, 1 To 6)
  With CreateObject("Scripting.Dictionary")
    For i = 1 To stt
      tmp = Arr(i)
      If tmp(0) < tmp(1) Then noBln = True Else noBln = False
      For j = 2 To UBound(tmp)
        ik = tmp(j)
        If noBln Then
          TK1 = 2: TK2 = 5
          C1 = 3: C2 = 4
        Else
          TK1 = 5: TK2 = 2
          C1 = 4: C2 = 3
        End If
        iKey = sArr(ik, TK1)
        If Not .exists(iKey) Then
          k = k + 1
          .Add iKey, ""
          ID = k
         
          Res(k, 1) = sArr(ik, 1)
          Res(k, 2) = iKey
         
          If Thang <> Res(k, 1) Then
            Thang = Res(k, 1)
            t = 1
          Else
            t = t + 1
          End If
          Res(k, 5) = t
          Res(k, 6) = sArr(ik, 4)
          For r = j To UBound(tmp)
            q = tmp(r)
            If iKey = sArr(q, TK1) Then
              k = k + 1
              Res(k, 1) = sArr(q, 1)
              Res(k, 2) = sArr(q, TK2)
              Res(k, C2) = sArr(q, 3)
              Res(k, 5) = t
              Res(k, 6) = sArr(q, 4)
              Res(ID, C1) = Res(ID, C1) + sArr(q, 3)
            End If
          Next r
        End If
      Next j
      .RemoveAll
    Next i
  End With
  Sheet1.Range("H2").Resize(k, 6).Value = Res
End Sub

Private Sub LocData()
  Dim tmp
  Dim iKey As String, nKey As String, TKno As String, TKco As String
  Dim sRow As Long, i As Long, tt As Long, ik As Long, dau As Long

  n = 0: stt = 0
  With CreateObject("Scripting.Dictionary")
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      If sArr(i, 3) <> 0 Then
        iKey = sArr(i, 1) & "#" & sArr(i, 4)
        If Not .exists(iKey) Then
          stt = stt + 1
          .Add iKey, stt
          ReDim Preserve Arr(1 To stt)
          Arr(stt) = Array(0, 0)
        End If
        tt = .Item(iKey)
        If sArr(i, 3) > 0 Then
          TKno = sArr(i, 5): TKco = sArr(i, 2): dau = 1
        Else
          TKno = sArr(i, 2): TKco = sArr(i, 5): dau = -1
        End If
        nKey = iKey & "N" & TKno & "C" & TKco
        If Not .exists(nKey) Then
          n = n + 1
          .Add nKey, n
          sArr(n, 1) = sArr(i, 1)
          sArr(n, 2) = TKno
          sArr(n, 3) = sArr(i, 3) * dau
          sArr(n, 4) = sArr(i, 4)
          sArr(n, 5) = TKco
          sArr(n, 6) = tt
          tmp = Arr(tt)
          ReDim Preserve tmp(0 To UBound(tmp) + 1)
          tmp(UBound(tmp)) = n
          Arr(tt) = tmp
        Else
          ik = .Item(nKey)
          sArr(ik, 3) = sArr(ik, 3) + sArr(i, 3) * dau
        End If
        nKey = iKey & "N" & TKno
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(0) = tmp(0) + 1
          Arr(tt) = tmp
        End If
        nKey = iKey & "C" & TKco
        If Not .exists(nKey) Then
          .Add nKey, ""
          tmp = Arr(tt)
          tmp(1) = tmp(1) + 1
          Arr(tt) = tmp
        End If
      End If
    Next i
  End With
End Sub

Em cảm ơn anh nhiều ạ !

Chuyển đổi bảng dữ liệu sang dạng mong muốn

vanvan9697

Thành viên chính thức

File đính kèm

HieuCD

Chuyên gia GPE

vanvan9697

Thành viên chính thức

HieuCD

Chuyên gia GPE

vanvan9697

Thành viên chính thức

ongke0711

Thành viên gắn bó

SA_DQ

/(hông là gì!

vanvan9697

Thành viên chính thức

SA_DQ

/(hông là gì!

vanvan9697

Thành viên chính thức

HieuCD

Chuyên gia GPE

vanvan9697

Thành viên chính thức

HieuCD

Chuyên gia GPE

vanvan9697

Thành viên chính thức

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

Facebook

Group

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