Cách tách dữ liệu trong 1 dòng thành nhiều dòng

[quick87]

Bạn nên xoá dữ liệu bớt đi. Để lại 1 ít thôi. Và kết quả điền bằng tay xem thế nào. mình vẫn chưa thông được cái đoạn
Gom các cột có số liệu khác 0 từ Cột C đến Cột J về lại một cột theo từng nhóm
này luôn ấy

Mình gửi lại file kết quả đã lược bớt dữ liệu.



Khi thực hiện thao tác thủ công bằng tay sẽ thực hiện các bước như sau:

1. Filter Cột A:C, lọc những giá trị > 0, copy vùng lọc được sang Cột N:Q;
2. Tiếp đó, Filter Cột D, lọc những giá trị > 0, copy vùng lọc được (Cột A, B, D), copy paste nối tiếp sang vùng ở Cột N:Q;
3. Filter Cột E, lọc những giá trị > 0, copy vùng lọc được (Cột A, B, E), copy paste nối tiếp sang vùng ở Cột N:Q;
4. ....
5. Làm tương tự với những Cột còn lại cho tới hết những cột còn lại.

 

[BuiQuangThuan]

Mình gửi lại file kết quả đã lược bớt dữ liệu.

Chỉnh lại code

Sub XYZ()
    Dim Arr(), Res(), i&, J&, iRow&, K&
With Sheet1
    iRow = .Range("B" & Rows.Count).End(3).Row
    Arr = .Range("A1:J" & iRow).Value
    ReDim Res(1 To UBound(Arr, 1) * (UBound(Arr, 2) - 2), 1 To 4)
    For J = 3 To UBound(Arr, 2)
        For i = 2 To UBound(Arr, 1)
            If Val(Arr(i, J)) > 0 Then
                K = K + 1
                Res(K, 1) = Arr(i, 1)
                Res(K, 2) = Arr(i, 2)
                Res(K, 3) = Arr(1, J)
                Res(K, 4) = Arr(i, J)
            End If
        Next
    Next
    .Range("N2:Q" & .Rows.Count).ClearContents
    .Range("N2").Resize(K, 4).Value = Res
End With
End Sub

 

[quick87]

Chỉnh lại code

Sub XYZ()
    Dim Arr(), Res(), i&, J&, iRow&, K&
With Sheet1
    iRow = .Range("B" & Rows.Count).End(3).Row
    Arr = .Range("A1:J" & iRow).Value
    ReDim Res(1 To UBound(Arr, 1) * (UBound(Arr, 2) - 2), 1 To 4)
    For J = 3 To UBound(Arr, 2)
        For i = 2 To UBound(Arr, 1)
            If Val(Arr(i, J)) > 0 Then
                K = K + 1
                Res(K, 1) = Arr(i, 1)
                Res(K, 2) = Arr(i, 2)
                Res(K, 3) = Arr(1, J)
                Res(K, 4) = Arr(i, J)
            End If
        Next
    Next
    .Range("N2:Q" & .Rows.Count).ClearContents
    .Range("N2").Resize(K, 4).Value = Res
End With
End Sub

Kết quả đúng như mình cần rồi. Chân thành cảm bạn!

 

[Talaytalo]

NHỜ MỌI NGƯỜI GIÚP E VỚI, E CÓ 1 FILE CÓ 1 DÒNG TỔNG SỐ LIỆU E MUỐN TÁCH DỮ LIỆU THÀNH NHIỀU DÒNG NHỎ Ạ!

 

[SA_DQ]

Thì bạn cứ Copy & dán thôi;
Nếu muốn đỡ vất vả thì thực hiện việc Copy & dán nhuần nghuyễn, sau đó mở bộ thu macro lên là OK mà!
Nếu thấy các câu lệnh trong macro lôi thôi thì gởi lên anh cộng đồng cô gọn cho duyên dáng thêm!
Chúc ngày nghỉ cuối tuần vui vẻ!

 

[Talaytalo]

Thì bạn cứ Copy & dán thôi;
Nếu muốn đỡ vất vả thì thực hiện việc Copy & dán nhuần nghuyễn, sau đó mở bộ thu macro lên là OK mà!
Nếu thấy các câu lệnh trong macro lôi thôi thì gởi lên anh cộng đồng cô gọn cho duyên dáng thêm!
Chúc ngày nghỉ cuối tuần vui vẻ!

ANH CHỊ CÓ CÁCH NÀO CHỈ E VỚI Ạ, E MỚI TÌM HỌC CÒN NHIỀU THỨ KHÔNG BIẾT Ạ!

 

[SA_DQ]

Sub CopyDongThanhBang()
 Dim Col As Integer, J As Long, Dong As Long

 Col = [B1].CurrentRegion.Cells.Count
 Dong = 4
 For J = 1 To Col Step 5
    Cells(1, J).Resize(, 5).Copy Destination:=Cells(Dong, "A")
    Dong = Dong + 1
 Next J
End Sub

 

[Talaytalo]

Sub CopyDongThanhBang()
 Dim Col As Integer, J As Long, Dong As Long

 Col = [B1].CurrentRegion.Cells.Count
 Dong = 4
 For J = 1 To Col Step 5
    Cells(1, J).Resize(, 5).Copy Destination:=Cells(Dong, "A")
    Dong = Dong + 1
 Next J
End Sub

EM CHÂN THÀNH CẢM ƠN Ạ!

 

[VetMini]

Bài viết toàn chữ hoa là phạm quy. Hỏng biết mấy người nghiện code có biết hông? Hay đối với cơn nghiện thì cái gì cũng phê được?

 

[SA_DQ]

Đúng, bài viết toàn chữ in đang là sai;
& cái sai này đã có người được phân công (phải nghiện) lo trước; /(HÀ, KHÀ, /(hà, khà, . . . . .
Trước mình cũng tham gia, nhưng giờ thì MAC KE NO. . . . .!