Dịch chuyển dữ liệu

[pt_hcl]

Vì số dữ liệu ở các cột là khác nhau nên Dữ liệu ban đầu được xắp xếp từ dòng 1 trở xuống dưới nên những dòng cuối cùng dữ liệu thụt ra thụt vào. Nay mong GPE làm thế nào để di chuyển dữ liệu để dữ liệu xắp sếp ở các cột đều kết thúc cùng một dòng cuối cùng (dòng dữ liệu nào ít số liệu hơn sẽ dịch chuyển xuống dưới để dữ liệu cuối cùng nằm cùng dòng dữ liệu ở tất cả các cột). Mong GPE xem giúp, xin cảm ơn!

 

[SA_DQ]

Bạn tham khảo macro này xem sao:

Sub XepLaiDuLieu()
 Dim Rws As Long, Col As Byte, J As Integer
 Dim Rng As Range
 
 With Cells(2, 3)
    Rws = .CurrentRegion.Rows.Count:        Col = .CurrentRegion.Columns.Count
    .Offset(, Col + 6).Resize(2 + Rws, 2 * Col).ClearContents
    For J = .Column To Col + .Column
        Set Rng = Range(.Cells(Rws + 9, J).End(xlUp), .Cells(Rws + 9, J).End(xlUp).End(xlUp))
        Cells(1 + Rws - Rng.Rows.Count, J + 22).Resize(Rws).Value = Rng.Value
    Next J
 End With
 Rows(Rws + 1 & ":" & 2 * Rws).Delete
End Sub

 

[pt_hcl]

Bạn tham khảo macro này xem sao:

Sub XepLaiDuLieu()
 Dim Rws As Long, Col As Byte, J As Integer
 Dim Rng As Range
 
 With Cells(2, 3)
    Rws = .CurrentRegion.Rows.Count:        Col = .CurrentRegion.Columns.Count
    .Offset(, Col + 6).Resize(2 + Rws, 2 * Col).ClearContents
    For J = .Column To Col + .Column
        Set Rng = Range(.Cells(Rws + 9, J).End(xlUp), .Cells(Rws + 9, J).End(xlUp).End(xlUp))
        Cells(1 + Rws - Rng.Rows.Count, J + 22).Resize(Rws).Value = Rng.Value
    Next J
 End With
 Rows(Rws + 1 & ":" & 2 * Rws).Delete
End Sub

Cảm ơn bạn rất nhiều. Mong bạn xem giúp kết quả xuất sang sheet2 được không ạ? và tuỳ biến sao cho dữ liệu ở sheet1 có bao nhiêu cột thì sang sheet2 kết quả dữ liệu cũng sắp xếp lại đủ bấy nhiêu cột! Xin cảm ơn!

 

[SA_DQ]

Option Explicit
Sub XepLaiDuLieu()
 Dim Rws As Long, Col As Byte, J As Integer, Dg As Long
 Dim Rng As Range, Cls As Range
 Dim MyAdd As String
 
 Set Rng = Sheet1.Cells(2, 4).CurrentRegion
 Rws = Rng.Rows.Count:          Col = Rng.Columns.Count
 MyAdd = Rng(1).Address
 Sheet2.Range(MyAdd).Resize(2 * Rws, 2 * Col).ClearContents
 For Each Cls In Rng(1).Resize(, Col)
    Dg = Cls.End(xlDown).Row
    If Dg = Rws Then
        Sheet2.Range(Cls.Address).Resize(Rws).Value = Cls.Resize(Rws).Value
    ElseIf Dg < Rws Then
        Sheet2.Range(Cls.Address).Offset(Rws - Dg).Resize(Rws).Value = Cls.Resize(Rws).Value
    End If
 Next Cls
End Sub