Nhờ a/c giúp cách gộp các giá trị khác dòng thành 1 dòng có điều kiện

Tung08.van đã viết:

Chào anh chị,
Em có 1 file đính kèm bên dưới,anh chị giúp em làm cách nào để
-Nếu như ngày trùng nhau thì sẽ gộp dữ liệu của 2 mục có dữ liệu xong điền vào 2 mục không có dữ liệu để tạo thành 1 ngày có cả 4 mục đầy đủ.
-Thoả mãn điều kiện thì dữ liệu cũ đi.
Anh chị tham khảo file đính kèm để hiểu rõ ý em hơn ạ.
Em cảm ơn!

Nhấp chuột vào đây để mở rộng...

Sub hensui()
    Dim arr, i As Long, b As Long, dk As Long, dic As Object, a As Long, kq
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         arr = .Range("B5:F17").Value
         ReDim kq(1 To UBound(arr), 1 To 5)
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = Format(arr(i, 1), "DD-MM-YYYY")
                kq(a, 2) = arr(i, 2)
                kq(a, 3) = arr(i, 3)
                kq(a, 4) = arr(i, 4)
                kq(a, 5) = arr(i, 5)
                dic.Add dk, a
             Else
                b = dic.Item(dk)
                kq(b, 2) = kq(b, 2) & arr(i, 2)
                kq(b, 3) = kq(b, 3) + arr(i, 3)
                kq(b, 4) = kq(b, 4) & arr(i, 4)
                kq(b, 5) = kq(b, 5) + arr(i, 5)
             End If
        Next i
        If a Then .Range("h5:l5").Resize(a).Value = kq
    End With
End Sub

snow25 đã viết:

Bạn thử hên sui nhé.Vì code chỉ viết theo đúng yêu cầu không kiểm soát lỗi.

Mã:Sao chép.

Sub hensui()
    Dim arr, i As Long, b As Long, dk As Long, dic As Object, a As Long, kq
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         arr = .Range("B5:F17").Value
         ReDim kq(1 To UBound(arr), 1 To 5)
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = Format(arr(i, 1), "DD-MM-YYYY")
                kq(a, 2) = arr(i, 2)
                kq(a, 3) = arr(i, 3)
                kq(a, 4) = arr(i, 4)
                kq(a, 5) = arr(i, 5)
                dic.Add dk, a
             Else
                b = dic.Item(dk)
                kq(b, 2) = kq(b, 2) & arr(i, 2)
                kq(b, 3) = kq(b, 3) + arr(i, 3)
                kq(b, 4) = kq(b, 4) & arr(i, 4)
                kq(b, 5) = kq(b, 5) + arr(i, 5)
             End If
        Next i
        If a Then .Range("h5:l5").Resize(a).Value = kq
    End With
End Sub

Nhấp chuột vào đây để mở rộng...

snow25 đã viết:

Bạn thử hên sui nhé.Vì code chỉ viết theo đúng yêu cầu không kiểm soát lỗi.

Mã:Sao chép.

Sub hensui()
    Dim arr, i As Long, b As Long, dk As Long, dic As Object, a As Long, kq
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         arr = .Range("B5:F17").Value
         ReDim kq(1 To UBound(arr), 1 To 5)
         For i = 1 To UBound(arr)
             dk = arr(i, 1)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = Format(arr(i, 1), "DD-MM-YYYY")
                kq(a, 2) = arr(i, 2)
                kq(a, 3) = arr(i, 3)
                kq(a, 4) = arr(i, 4)
                kq(a, 5) = arr(i, 5)
                dic.Add dk, a
             Else
                b = dic.Item(dk)
                kq(b, 2) = kq(b, 2) & arr(i, 2)
                kq(b, 3) = kq(b, 3) + arr(i, 3)
                kq(b, 4) = kq(b, 4) & arr(i, 4)
                kq(b, 5) = kq(b, 5) + arr(i, 5)
             End If
        Next i
        If a Then .Range("h5:l5").Resize(a).Value = kq
    End With
End Sub

Nhấp chuột vào đây để mở rộng...

Tung08.van đã viết:

Chào anh chị,
Em có 1 file đính kèm bên dưới,anh chị giúp em làm cách nào để
-Nếu như ngày trùng nhau thì sẽ gộp dữ liệu của 2 mục có dữ liệu xong điền vào 2 mục không có dữ liệu để tạo thành 1 ngày có cả 4 mục đầy đủ.
-Thoả mãn điều kiện thì dữ liệu cũ đi.
Anh chị tham khảo file đính kèm để hiểu rõ ý em hơn ạ.
Em cảm ơn!

Nhấp chuột vào đây để mở rộng...

Sub ABC()
  Dim sArr(), Res(), dic As Object, iKey$, iKey2$
  Dim sRow&, i&, k&, iR&, jCol&, tmp$
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    sArr = .Range("B5:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 5)
  For i = 1 To UBound(sArr)
    jCol = 0
    If sArr(i, 2) <> Empty And sArr(i, 4) <> Empty Then
      k = k + 1
      For j = 1 To 5
        Res(k, j) = sArr(i, j)
      Next j
    ElseIf sArr(i, 2) = Empty And sArr(i, 4) <> Empty Then
      jCol = 2:   jCol2 = 4
    ElseIf sArr(i, 2) <> Empty And sArr(i, 4) = Empty Then
      jCol = 4:   jCol2 = 2
    End If
    If jCol <> 0 Then
      iKey = sArr(i, 1) & "#" & jCol
      iKey2 = sArr(i, 1) & "#" & jCol2
      tmp = dic.Item(iKey)
      If Len(tmp) = 0 Then
        k = k + 1
        dic.Item(iKey2) = dic.Item(iKey2) & "," & k
        Res(k, 1) = sArr(i, 1)
        Res(k, jCol2) = sArr(i, jCol2)
        Res(k, jCol2 + 1) = sArr(i, jCol2 + 1)
      Else
        n = InStr(2, tmp, ",")
        If n > 0 Then n = n - 1 Else n = Len(tmp) - 1
        iR = Mid(tmp, 2, n)
        Res(iR, jCol2) = sArr(i, jCol2)
        Res(iR, jCol2 + 1) = sArr(i, jCol2 + 1)
        dic.Item(iKey) = Replace(tmp, "," & iR, "", 1, 1)
      End If
    End If
  Next i
  If k Then Sheets("sheet1").Range("H5:L5").Resize(k).Value = Res
End Sub