Giúp chuyển dữ liệu từ bảng dọc sang bảng ngang theo qui tắc có sẵn (1 người xem)

[d1207t]

Kính gửi: Các Anh Chị diễn đàn.

Hiện em có nhận được dữ liệu được xuất ra không theo qui tắc thông thường lên mất nhiều thời gian để copy lại dữ liệu và dễ xảy ra sai sót. Em mong các anh chị hỗ trợ để có thể sắp xếp nhanh dữ liệu bằng VBA ạ.
Hiện tại ở Sheet1 là dữ liệu gốc, mỗi "Item" chiếm 6 dòng và nối tiếp nhau. Như ở Sheet1 em có demo 5 Item. Hiện em muốn các sắp xếp lại dữ liệu như Sheet2.
Mong các anh chị hỗ trợ giúp đỡ em với ạ.
Trân trọng cảm ơn.

 

[HieuCD]

Kính gửi: Các Anh Chị diễn đàn.

Hiện em có nhận được dữ liệu được xuất ra không theo qui tắc thông thường lên mất nhiều thời gian để copy lại dữ liệu và dễ xảy ra sai sót. Em mong các anh chị hỗ trợ để có thể sắp xếp nhanh dữ liệu bằng VBA ạ.
Hiện tại ở Sheet1 là dữ liệu gốc, mỗi "Item" chiếm 7 dòng và nối tiếp nhau. Như ở Sheet1 em có demo 5 Item. Hiện em muốn các sắp xếp lại dữ liệu như Sheet2.
Mong các anh chị hỗ trợ giúp đỡ em với ạ.
Trân trọng cảm ơn.

Xem công thức trong file

 

[d1207t]

Xem công thức trong file

Em cảm ơn bác nhiều ạ.

 

[ptm0412]

Code nhanh:

Sub VerticalToHorizontal()
Dim LastRw As Long, SArr(), RArr()
LastRw = Sheet1.[B10000].End(xlUp).Row
SArr = Sheet1.Range("B2:D" & LastRw).Value
ReDim RArr(1 To (LastRw - 1) / 6, 1 To 9)
For i = 1 To UBound(SArr, 1) Step 6
    k = k + 1
    RArr(k, 1) = k
    RArr(k, 2) = SArr(i + 4, 1)
    RArr(k, 3) = SArr(i + 5, 1)
    RArr(k, 4) = SArr(i + 4, 2)
    RArr(k, 5) = SArr(i + 5, 2)
    RArr(k, 6) = SArr(i, 1)
    RArr(k, 7) = SArr(i + 1, 1)
    RArr(k, 8) = SArr(i + 4, 3)
    RArr(k, 9) = SArr(i + 5, 3)
Next
Sheet2.Range("A2:I100").ClearContents
Sheet2.[A2].Resize(k, 9).Value = RArr
    
End Sub

 

[d1207t]

Code nhanh:

Sub VerticalToHorizontal()
Dim LastRw As Long, SArr(), RArr()
LastRw = Sheet1.[B10000].End(xlUp).Row
SArr = Sheet1.Range("B2:D" & LastRw).Value
ReDim RArr(1 To (LastRw - 1) / 6, 1 To 9)
For i = 1 To UBound(SArr, 1) Step 6
    k = k + 1
    RArr(k, 1) = k
    RArr(k, 2) = SArr(i + 4, 1)
    RArr(k, 3) = SArr(i + 5, 1)
    RArr(k, 4) = SArr(i + 4, 2)
    RArr(k, 5) = SArr(i + 5, 2)
    RArr(k, 6) = SArr(i, 1)
    RArr(k, 7) = SArr(i + 1, 1)
    RArr(k, 8) = SArr(i + 4, 3)
    RArr(k, 9) = SArr(i + 5, 3)
Next
Sheet2.Range("A2:I100").ClearContents
Sheet2.[A2].Resize(k, 9).Value = RArr
   
End Sub

Cảm ơn bác, quá tuyệt luôn

 

[ptm0412]

Cảm ơn bác, quá tuyệt luôn

May là tôi biết đếm và đếm lại ra 6, chứ không phải 7 như bài 1.

 

[d1207t]

May là tôi biết đếm và đếm lại ra 6, chứ không phải 7 như bài 1

Vâng bác, em xin điều chỉnh lại nội dung trợ giúp ạ.

 

[Maika8008]

May là tôi biết đếm và đếm lại ra 6, chứ không phải 7 như bài 1.

Bác học đếm tài quá

 

[phuongvq123]

tham khảo file với công thức đơn giản