[Gởi các bạn nhờ giúp đỡ] Sắp xếp dữ liệu.

[hacklongem]

Nhờ các bạn giúp đỡ.
Tôi có một file dữ liệu cần sắp xếp lại.Mong các bạn giúp đỡ .Xin chân thành cám ơn.

 

[SA_DQ]

Bạn cho chạy macro này & những mong khỏi đưa file lên

Option Explicit
Sub gpeXepLai()
 Dim Cls As Range, Rng As Range
 Dim jJ As Byte
 
 [n1].CurrentRegion.Offset(1).Clear
 For Each Cls In Range([b5], [b5].End(xlDown))
    Set Rng = Cls.Offset(, 1).Resize(, 9)
    For jJ = 1 To 9 Step 2
        If Rng(jJ).Value = "" Then Exit For
        
        With [N65500].End(xlUp)
            Rng(jJ).Resize(, 2).Copy Destination:=.Offset(1)
            If jJ = 1 Then .Offset(1, -1) = Cls.Offset(, -1).Value
        End With
    Next jJ
 Next Cls
End Sub

 

[hacklongem]

cám ơn bạn. Nhưng vẫn thiếu cột B vùng dữ liệu cần trước khi sắp xếp.
(Xin lỗi là mình không biết đưa lên box nào nữa.)

 

[nhapmon]

cám ơn bạn. Nhưng vẫn thiếu cột B vùng dữ liệu cần trước khi sắp xếp.
(Xin lỗi là mình không biết đưa lên box nào nữa.)

thử làm bằng công thức, để xem thui, chứ dữ liệu bạn cả ngày dòng chắc chay ko nổi.
mình cũng đã mạo muội chỉnh lại một chút code của bác HYen theo yêu cầu của bạn

 

[concogia]

cám ơn bạn. Nhưng vẫn thiếu cột B vùng dữ liệu cần trước khi sắp xếp.
(Xin lỗi là mình không biết đưa lên box nào nữa.)

Một cách viết:

Public Sub SapXep()
    Dim Vung, I, J, K, Kq
    Vung = [B5:H8]
    ReDim Kq(1 To UBound(Vung) * 4, 1 To 3)
    For I = 1 To UBound(Vung)
        K = K + 1: Kq(K, 1) = I: Kq(K, 2) = Vung(I, 1)
        For J = 2 To 6 Step 2
            If Vung(I, J) <> "" Then
                K = K + 1
                Kq(K, 2) = Vung(I, J): Kq(K, 3) = Vung(I, J + 1)
            End If
        Next J
    Next I
[Q2:S1000].ClearContents
[Q2].Resize(K, 3) = Kq
End Sub

Kết quả ở cột [Q]
Thân

 

[hacklongem]

Một cách viết:

Public Sub SapXep()
    Dim Vung, I, J, K, Kq
    Vung = [B5:H8]
    ReDim Kq(1 To UBound(Vung) * 4, 1 To 3)
    For I = 1 To UBound(Vung)
        K = K + 1: Kq(K, 1) = I: Kq(K, 2) = Vung(I, 1)
        For J = 2 To 6 Step 2
            If Vung(I, J) <> "" Then
                K = K + 1
                Kq(K, 2) = Vung(I, J): Kq(K, 3) = Vung(I, J + 1)
            End If
        Next J
    Next I
[Q2:S1000].ClearContents
[Q2].Resize(K, 3) = Kq
End Sub

Kết quả ở cột [Q]
Thân

Cám ơn bạn nhiều . Đúng ý đồ của mình rồi. Đây là file thực tế bạn giúp mình luôn nha. Cám ơn bạn nhiều (file update nha)

 

[concogia]

Cám ơn bạn nhiều . Đúng ý đồ của mình rồi. Đây là file thực tế bạn giúp mình luôn nha. Cám ơn bạn nhiều

Dữ liệu các cột [C[, [E], [G], , [K], [M] nên thống nhất một kiểu khi không có dữ liệu ( thí dụ dùng dấu "-" thì nên dùng toàn bộ) để kết quả không bị lỗi
Thân

 

[hacklongem]

Tốt quá rất cám ơn bạn. Nếu bạn ở Thành phố thì cho mình mời bạn 1 ly caphe nhá.