Nối dữ liệu trên nhiều dòng

[vantuan2939]

Chào cả nhà. E có 1 bài toán cần chuyển dữ liệu dọc thành ngang và nối dữ liệu như file đính kèm trong đó ở cột B (cột thời gian bao gồm ngày tháng và thời gian cần tách thành 2 cột: cột ngày tháng và cột thời gian) và cột D (nội dung 1 và nội dung 2 được tách thành 2 cột rời nhau, còn nội dung 3 trở đi được nối lại với nhau ở cột sau cột nội dung 2). sheet!DATA là dữ liệu nguồn, còn sheet!joint là kết quả cần tách và nối như đề bài. E cám ơn!

 

[snow25]

Chào cả nhà. E có 1 bài toán cần chuyển dữ liệu dọc thành ngang và nối dữ liệu như file đính kèm trong đó ở cột B (cột thời gian bao gồm ngày tháng và thời gian cần tách thành 2 cột: cột ngày tháng và cột thời gian) và cột D (nội dung 1 và nội dung 2 được tách thành 2 cột rời nhau, còn nội dung 3 trở đi được nối lại với nhau ở cột sau cột nội dung 2). sheet!DATA là dữ liệu nguồn, còn sheet!joint là kết quả cần tách và nối như đề bài. E cám ơn!

Bạn thử.

Sub chuyendulieu()
    Dim arr, i As Long, lr As Long, kq, a As Long, b As Long, c As Long
    With Sheets("data")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A4:H" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 11)
    End With
        For i = 1 To UBound(arr)
            If arr(i, 1) <> Empty Then
               If arr(i, 3) <> Empty Then b = i: a = a + 1: c = 0
               c = c + 1
               If c > 3 Then c = 3
               kq(a, 1) = arr(b, 1)
               kq(a, 2) = arr(b, 2)
               kq(a, 3) = arr(b + 1, 2)
               kq(a, 4) = arr(b, 3)
               kq(a, 4 + c) = Application.Trim(kq(a, 4 + c) & " " & arr(i, 4))
               kq(a, 8) = arr(b, 5)
               kq(a, 9) = arr(b, 6)
               kq(a, 10) = arr(b, 7)
               kq(a, 11) = arr(b, 8)
            End If
       Next i
   With Sheets("joint")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 2 Then .Range("A2:K" & lr).ClearContents
        .Range("A2").Resize(a, 11).Value = kq
   End With
End Sub

 

[vantuan2939]

Bạn thử.

Sub chuyendulieu()
    Dim arr, i As Long, lr As Long, kq, a As Long, b As Long, c As Long
    With Sheets("data")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A4:H" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 11)
    End With
        For i = 1 To UBound(arr)
            If arr(i, 1) <> Empty Then
               If arr(i, 3) <> Empty Then b = i: a = a + 1: c = 0
               c = c + 1
               If c > 3 Then c = 3
               kq(a, 1) = arr(b, 1)
               kq(a, 2) = arr(b, 2)
               kq(a, 3) = arr(b + 1, 2)
               kq(a, 4) = arr(b, 3)
               kq(a, 4 + c) = Application.Trim(kq(a, 4 + c) & " " & arr(i, 4))
               kq(a, 8) = arr(b, 5)
               kq(a, 9) = arr(b, 6)
               kq(a, 10) = arr(b, 7)
               kq(a, 11) = arr(b, 8)
            End If
       Next i
   With Sheets("joint")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 2 Then .Range("A2:K" & lr).ClearContents
        .Range("A2").Resize(a, 11).Value = kq
   End With
End Sub

Cám ơn bác. Đúng cái e cần. em xin đóng bài tại đây.