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

Thành viên mới
Tham gia ngày
20 Tháng sáu 2019
Bài viết
6
Được thích
0
Điểm
13
Tuổi
22
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!
 

File đính kèm

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,408
Được thích
2,276
Điểm
360
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!
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ã:
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
 

Tung08.van

Thành viên mới
Tham gia ngày
20 Tháng sáu 2019
Bài viết
6
Được thích
0
Điểm
13
Tuổi
22
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ã:
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
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ã:
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
Cảm ơn anh nhưng em thử code không đc. nó ghép cái đc cái không
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,187
Được thích
11,496
Điểm
1,560
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!
Mã:
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
 
Top Bottom