Nhờ các bác dùng code VBA sắp xếp lại dữ liệu giúp em file này với ạ. Cảm ơn các bác nhiều! (1 người xem)

[buiduydong93]

Nhờ các bác dùng code VBA sắp xếp lại dữ liệu giúp em file này với ạ. Cảm ơn các bác nhiều!

 

[Hoàng Tuấn 868]

Nhờ các bác dùng code VBA sắp xếp lại dữ liệu giúp em file này với ạ. Cảm ơn các bác nhiều!

Bạn tham khảo. . .

 

[buiduydong93]

Cảm ơn bác rất nhiều, có 1 vấn đè là em muốn để những dòng cùng ngày giống nhau thành 1 hàng, còn những ngày không có sản phẩm thì hàng ý để trống. Cột ngày thì chỉ lấy 1 cột đầu tiên để tham chiếu.

 

[Hoàng Tuấn 868]

Cảm ơn bác rất nhiều, có 1 vấn đè là em muốn để những dòng cùng ngày giống nhau thành 1 hàng, còn những ngày không có sản phẩm thì hàng ý để trống. Cột ngày thì chỉ lấy 1 cột đầu tiên để tham chiếu.

Bạn điền kết quả mong muốn vào file xem cụ thể thế nào.

 

[VetMini]

Bạn điền kết quả mong muốn vào file xem cụ thể thế nào.

Bảo thớt muốn làm gì thì record macro là xong. Nhờ viết code chi vậy?

 

[SA_DQ]

Cảm ơn bác rất nhiều, có 1 vấn đè là em muốn để những dòng cùng ngày giống nhau thành 1 hàng, còn những ngày không có sản phẩm thì hàng ý để trống. Cột ngày thì chỉ lấy 1 cột đầu tiên để tham chiếu.

Chạy macro này trên file #2:

Sub FilterData()
 Dim fDat As Date, lDat As Date, SoNgay As Integer, W As Integer, Rws As Long, J As Long, Dg As Long
 Dim WF As Object, Rng As Range, sRng As Range
 Dim MyAdd As String
 
 Rws = [B4].CurrentRegion.Rows.Count
 Set WF = Application.WorksheetFunction
 Set Rng = [B4].Resize(Rws)
 fDat = WF.Min(Rng):                    lDat = WF.Max(Rng)
' MsgBox lDat, , fDat       '
 SoNgay = lDat - fDat + 1:              Rng.NumberFormat = "MM/DD/yyyy"
 [I4].CurrentRegion.Offset(1).ClearContents
 For J = 0 To SoNgay
    Cells(99 * Rws, "I").End(xlUp).Offset(1).Value = Format(J + fDat, "MM/DD/yyyy")
    Dg = Cells(99 * Rws, "I").End(xlUp).Row
    Set sRng = Rng.Find(Format(J + fDat, "MM/DD/yyyy"), , xlValues, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            W = W + 1
            sRng.Offset(, 1).Resize(, 3).Copy Destination:=Cells(Dg, 3 * W + 7)
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        W = 0
    Else
        MsgBox "Nothing " & fDat + J
    End If
 Next J
End Sub

 

[buiduydong93]

Cảm ơn các bác, cụ thể là kết quả mong muốn của em như File dưới đây ạ.

 

[buiduydong93]

Bạn điền kết quả mong muốn vào file xem cụ thể thế nào.

Kết quả giống như File này bác.

 

[Hoàng Tuấn 868]

Kết quả giống như File này bác.

Bạn thử xem lại nhé.

 

[BuiQuangThuan]

Bạn thử xem lại nhé.

Bài này anh dùng dictionary làm được này

 

[Hoàng Tuấn 868]

Bài này anh dùng dictionary làm được này

Anh lười đấy, cũng định thế nhưng lại thôi.

 

[buiduydong93]

Bạn thử xem lại nhé.

Thanks bác nhé , bài toán này em loay hoay mãi mà không sử lý được/

 

[BuiQuangThuan]

Bạn thử xem lại nhé.

Góp vui thêm 1 cách nữa sử dụng dic

Sub ABC()
Dim Dic As Object, Arr(), Res(), i&, K&, K2&, iR&, j%
Set Dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
With Sheets("Sheet1")
    iR = .Range("B" & Rows.Count).End(3).Row
    If iR < 4 Then MsgBox "Khong co du lieu": Exit Sub
    Arr = .Range("B3:E" & iR).Value2
End With
ReDim Res(1 To UBound(Arr) + 2, 1 To Columns.Count)
K2 = -1
For i = 2 To UBound(Arr, 1)
    If Dic.exists(Arr(i, 1)) = False Then
        K = K + 1
        Dic.Item(Arr(i, 1)) = K
        Res(K + 2, 1) = Arr(i, 1)
    End If
    If Dic.exists(Arr(i, 2)) = False Then
        K2 = K2 + 3
        ReDim Preserve Res(1 To UBound(Arr) + 2, 1 To K2 + 3)
        Dic.Item(Arr(i, 2)) = K2
        Res(1, K2) = Arr(i, 2)
        For j = 0 To 2
            Res(2, K2 + j) = Arr(1, j + 2)
        Next
    End If
        Res(Dic.Item(Arr(i, 1))+ 2,  Dic.Item(Arr(i, 2))) = Arr(i, 2)
        Res(Dic.Item(Arr(i, 1))+ 2,  Dic.Item(Arr(i, 2))+ 1) = Arr(i, 3)
        Res(Dic.Item(Arr(i, 1))+ 2,  Dic.Item(Arr(i, 2))+ 2) = Arr(i, 4)
Next
With Sheets("Sheet1")
    Res(2, 1) = Arr(1, 1)
    .Range("I1").Resize(100000, K2 + 2).Clear
    .Range("I1").Resize(K + 2, K2 + 2).Value = Res
    .Range("I2").Resize(K + 1, K2 + 2).Borders.LineStyle = 1
    .Range("I2").Resize(K + 1).NumberFormat = "m/d/yyyy"
End With
Application.ScreenUpdating = True
MsgBox "OK", vbInformation, "XXXXX"
End Sub