Sắp xếp lại dữ liệu (từ bậc thang thành 1 cột) (1 người xem)

[FatBear]

Dear Snow25,

Mình đã thử lại file mà bạn gửi lại, phần kết quả đúng là chỉ đến Team 3, còn từ Team 4 trở đi không thấy có kết quả. Mình check thì thấy data phần Team 4, Team 5...vẫn giống với team 1,2,3. Nhờ bạn kiểm tra giúp mình nhé. Cảm ơn bạn.

=)) ý của snow là data của bạn ko theo 1 quy luật nào cả, có những team nhảy cách 4 cột, lúc thì 5 cột, và có lúc không có dữ liệu => điều đó khiến code chạy không chính xác.

 

[parkjun]

=)) ý của snow là data của bạn ko theo 1 quy luật nào cả, có những team nhảy cách 4 cột, lúc thì 5 cột, và có lúc không có dữ liệu => điều đó khiến code chạy không chính xác.

nếu vậy mình tưởng từ team 1 đến team 5 chẳng hạn vẫn theo rule, từ team 6 trở đi mới nhảy cách thì khi chạy nó vẫn ra data từ 1 đến 5 chứ nhỉ

 

[snow25]

Dear Snow25,

Mình đã thử lại file mà bạn gửi lại, phần kết quả đúng là chỉ đến Team 3, còn từ Team 4 trở đi không thấy có kết quả. Mình check thì thấy data phần Team 4, Team 5...vẫn giống với team 1,2,3. Nhờ bạn kiểm tra giúp mình nhé. Cảm ơn bạn.

Bạn xem nhé.Sửa đúng theo dữ liệu của bạn.

Sub xapxep()
Application.ScreenUpdating = False
    Dim arr, I As Long, kq, lr As Long, lc As Long, b As Long, dk As String, J As Integer, a As Long, dks As String, c As Long
    With Sheets("Original Data")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         lc = .Cells(1, Columns.Count).End(xlToLeft).Column '+ 3
         arr = .Range("A1:A" & lr).Resize(, lc).Value
         ReDim kq(1 To UBound(arr), 1 To 7)
    End With
        dk = arr(2, 2)
        dks = arr(1, 7)
        b = 3
        c = 7
        For I = 2 To UBound(arr)
            kq(I - 1, 1) = arr(I, 1)
            kq(I - 1, 2) = arr(I, 2)
            If dk <> arr(I, 2) Then
               b = c + 1
               Do
                  c = c + 1
                  If arr(1, c) = dks Then
                     If arr(I, b) <> Empty Then
                        Exit Do
                     Else
                        b = c + 1
                     End If
                  End If
               Loop
               dk = arr(I, 2)
            End If
            For J = 3 To 7
                kq(I - 1, J) = arr(I, J + b - 3)
            Next J
       Next I
   With Sheets("ketqua")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        If lr > 1 Then .Range("A2:G" & lr).ClearContents
        .Range("A2:G2").Resize(I - 1).Value = kq
   End With
Application.ScreenUpdating = True
End Sub

 

[parkjun]

Bạn xem nhé.Sửa đúng theo dữ liệu của bạn.

Sub xapxep()
Application.ScreenUpdating = False
    Dim arr, I As Long, kq, lr As Long, lc As Long, b As Long, dk As String, J As Integer, a As Long, dks As String, c As Long
    With Sheets("Original Data")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         lc = .Cells(1, Columns.Count).End(xlToLeft).Column '+ 3
         arr = .Range("A1:A" & lr).Resize(, lc).Value
         ReDim kq(1 To UBound(arr), 1 To 7)
    End With
        dk = arr(2, 2)
        dks = arr(1, 7)
        b = 3
        c = 7
        For I = 2 To UBound(arr)
            kq(I - 1, 1) = arr(I, 1)
            kq(I - 1, 2) = arr(I, 2)
            If dk <> arr(I, 2) Then
               b = c + 1
               Do
                  c = c + 1
                  If arr(1, c) = dks Then
                     If arr(I, b) <> Empty Then
                        Exit Do
                     Else
                        b = c + 1
                     End If
                  End If
               Loop
               dk = arr(I, 2)
            End If
            For J = 3 To 7
                kq(I - 1, J) = arr(I, J + b - 3)
            Next J
       Next I
   With Sheets("ketqua")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        If lr > 1 Then .Range("A2:G" & lr).ClearContents
        .Range("A2:G2").Resize(I - 1).Value = kq
   End With
Application.ScreenUpdating = True
End Sub

Dear Snow25,

Chuẩn rồi bạn ạ. Cảm ơn bạn nhiều nhé, hỗ trợ nhiệt tình quá

 

[snow25]

Dear Snow25,

Chuẩn rồi bạn ạ. Cảm ơn bạn nhiều nhé, hỗ trợ nhiệt tình quá

Thực ra code vẫn còn lỗi do không sắp xếp đúng thứ tự bạn.Tự chỉnh chỗ đó nhé.

 

[HieuCD]

Hi Snow25,

Mình gửi lại file mình đang làm nhé

Cảm ơn bạn.

Bài đã được tự động gộp: 15/8/19

Mình gửi lại file ở comment trên rồi nhé

Góp vui với code chạy khá từ tốn

Sub ABC()
  Dim Res(), i&, eR&, eC&, j&, n&
  Application.ScreenUpdating = False
  With Sheets("Original Data (2)")
    eR = .Range("B" & Rows.Count).End(xlUp).Row
    ReDim Res(1 To eR - 1, 1 To 7)
    For i = 2 To eR
      Res(i - 1, 1) = .Cells(i, 1): Res(i - 1, 2) = .Cells(i, 2)
      eC = .Cells(i, Columns.Count).End(xlToLeft).Column
      For j = 0 To 4
        Res(i - 1, 3 + j) = .Cells(i, eC - 4 + j).Value
      Next j
    Next i
  End With

  With Sheets("KQ")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:G" & i).ClearContents
    .Range("A2:G2").Resize(eR - 1).Value = Res
  End With
  Application.ScreenUpdating = True
End Sub