Chuyển dạng dữ liệu

[totoha]

E đang có file như file đính kèm
Em muốn chuyển dữ liệu dang thế này
Mong các bác giúp e với

 

[johnnylinhanh]

Bạn làm cột phụ giờ từ 1 => 24 sau đó dùng pivot là ra bảng bạn cần rồi

 

[exthuctien]

E đang có file như file đính kèm
Em muốn chuyển dữ liệu dang thế này
Mong các bác giúp e với
View attachment 275896

không biết ý bạn phải thế này không
=TEXT(A3,"dd/mm/yyyy")

 

[totoha]

pivot table e làm ra được
Vì số liệu ở dạnh này mình dùng nhiều nếu viết được code thì sẽ dễ xử lý hơn ah
Trước mắt e chỉ xử lý số liệu này sau còn nhiều loại số liệu nữa nên e muốn giúp đỡ code để dễ xử lý hơn ah

 

[Phuocam]

Ngoài lề: Làm gì có 24 h, khi lên trên 23:59, nó tăng lên 1 ngày và trở về 00:00

.

 

[BuiQuangThuan]

không biết ý bạn phải thế này không
=TEXT(A3,"dd/mm/yyyy")

Bạn ý muốn kết quả trải ra theo kiểu này sao ấy. Có điều là lười không điền kết quả mẫu vào thì phải

 

[bebo021999]

Cột A bị trùng từ dòng 5029 - 5035. Delete đi nhé

Option Explicit
Sub test()
Dim lr&, t&, k&, s, cell As Range, arr(), dic As Object
Set dic = CreateObject("Scripting.dictionary")
lr = Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To Int((lr - 2) / 24) + 1, 1 To 24)
    For Each cell In Range("A3:A" & lr)
        s = Split(cell, " ")
        If Not dic.exists(s(0)) Then
            t = 1
            k = k + 1
            dic.Add s(0), k
            arr(k, t) = cell.Offset(0, 1)
        Else
            t = t + 1
            arr(k, t) = cell.Offset(0, 1)
        End If
    Next
Range("H5").Resize(dic.Count, 1).Value = WorksheetFunction.Transpose(dic.keys)
Range("I5").Resize(dic.Count, 24).Value = arr
End Sub

 

[snow25]

Cột A bị trùng từ dòng 5029 - 5035. Delete đi nhé

Option Explicit
Sub test()
Dim lr&, t&, k&, s, cell As Range, arr(), dic As Object
Set dic = CreateObject("Scripting.dictionary")
lr = Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To Int((lr - 2) / 24) + 1, 1 To 24)
    For Each cell In Range("A3:A" & lr)
        s = Split(cell, " ")
        If Not dic.exists(s(0)) Then
            t = 1
            k = k + 1
            dic.Add s(0), k
            arr(k, t) = cell.Offset(0, 1)
        Else
            t = t + 1
            arr(k, t) = cell.Offset(0, 1)
        End If
    Next
Range("H5").Resize(dic.Count, 1).Value = WorksheetFunction.Transpose(dic.keys)
Range("I5").Resize(dic.Count, 24).Value = arr
End Sub

Nếu dữ liệu chuẩn chắc không cần dùng Dictionary.
Thử code.

Sub hensui()
    Dim i As Long, lr As Long, arr, kq, a As Long, j As Long, b As Long, dic As Object, ngay As Long, c As Long, e As Integer, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A3:B" & lr).Value
         ReDim kq(1 To UBound(arr) \ 24 + 10, 1 To 25)
         a = 1
         For i = 1 To 24
             kq(a, i + 1) = i
         Next i
         For i = 1 To UBound(arr)
             e = InStr(arr(i, 1), " ")
             dk = Left(arr(i, 1), e)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = Format(arr(i, 1), "yyyy/mm/dd")
                kq(a, 2) = arr(i, 2)
                dic.Add dk, a
             Else
                c = dic.Item(dk)
                b = Hour(arr(i, 1)) +2
                kq(c, b) = arr(i, 2)
             End If
         Next i
         .Range("E3:E1000").Resize(, 25).ClearContents
         .Range("e3").Resize(a, 25).Value = kq
    End With
End Sub

 

[totoha]

Bạn ý muốn kết quả trải ra theo kiểu này sao ấy. Có điều là lười không điền kết quả mẫu vào thì phải
View attachment 275905

Đúng e đang cần làm theo bảo này
và cũng ko muốn làm thủ công từng bảng 1 vì cả bảng là hơn 1 năm dữ liệu và nhiều điểm nên e muốn code để được nhanh hơn ah
Cảm ơn bác

Bài đã được tự động gộp: 13/5/22

Cột A bị trùng từ dòng 5029 - 5035. Delete đi nhé

Option Explicit
Sub test()
Dim lr&, t&, k&, s, cell As Range, arr(), dic As Object
Set dic = CreateObject("Scripting.dictionary")
lr = Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To Int((lr - 2) / 24) + 1, 1 To 24)
    For Each cell In Range("A3:A" & lr)
        s = Split(cell, " ")
        If Not dic.exists(s(0)) Then
            t = 1
            k = k + 1
            dic.Add s(0), k
            arr(k, t) = cell.Offset(0, 1)
        Else
            t = t + 1
            arr(k, t) = cell.Offset(0, 1)
        End If
    Next
Range("H5").Resize(dic.Count, 1).Value = WorksheetFunction.Transpose(dic.keys)
Range("I5").Resize(dic.Count, 24).Value = arr
End Sub

Nếu dữ liệu chuẩn chắc không cần dùng Dictionary.
Thử code.

Sub hensui()
    Dim i As Long, lr As Long, arr, kq, a As Long, j As Long, b As Long, dic As Object, ngay As Long, c As Long, e As Integer, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A3:B" & lr).Value
         ReDim kq(1 To UBound(arr) \ 24 + 10, 1 To 25)
         a = 1
         For i = 1 To 24
             kq(a, i + 1) = i
         Next i
         For i = 1 To UBound(arr)
             e = InStr(arr(i, 1), " ")
             dk = Left(arr(i, 1), e)
             If Not dic.exists(dk) Then
                a = a + 1
                kq(a, 1) = Format(arr(i, 1), "yyyy/mm/dd")
                dic.Add dk, a
             Else
                c = dic.Item(dk)
                b = Hour(arr(i, 1)) + 1
                kq(c, b) = arr(i, 2)
             End If
         Next i
         .Range("E3:E1000").Resize(, 25).ClearContents
         .Range("e3").Resize(a, 25).Value = kq
    End With
End Sub

Cảm ơn 2 bác
E sẽ ngâm cứu chút để thay đổi cho phù hợp với ý tưởng của mình
về dữ liệu thì chuẩn theo mẫu , vì e trích xuất ko được nhiều nên gộp lại mới có sự trùng lặp
1 lần nữa cảm ơn 2 bác đã hỗ trợ