Tách thành nhiều dòng theo điều kiện (3 người xem)

[dahoydu]

Anh/chị cho em hỏi mình có cách nào tách dữ liệu thành nhiều dòng dựa theo điều kiện.
Vd: E có 1 bảng "data" vào như file đính kèm, tương ứng điều kiện của "number_subject", sẽ hiển thị kết quả tương ứng như sheet "result".

 

[Nhattanktnn]

Anh/chị cho em hỏi mình có cách nào tách dữ liệu thành nhiều dòng dựa theo điều kiện.
Vd: E có 1 bảng "data" vào như file đính kèm, tương ứng điều kiện của "number_subject", sẽ hiển thị kết quả tương ứng như sheet "result".

Bạn thử dùng code này nhé:

Option Explicit

Sub TachDuLieu()
Dim sArr(), dArr(), I&, J&, K&, sU1&, sU2&, dU1&, dU2&
With Sheets("Data")
    sArr = .Range("A2:D" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
    sU1 = UBound(sArr, 1)
    sU2 = UBound(sArr, 2)
    dU1 = WorksheetFunction.Sum(WorksheetFunction.Index(sArr, 0, 4))
    dU2 = 3
End With
ReDim dArr(1 To dU1, 1 To dU2)
For I = 1 To sU1
    For J = 1 To sArr(I, 4)
        K = K + 1
        dArr(K, 1) = sArr(I, 1)
        dArr(K, 2) = sArr(I, 2)
        dArr(K, 3) = sArr(I, 3)
    Next
Next
With Sheets("result")
    If K Then
        .Range("E2").Resize(Rows.Count - 10, 3).ClearContents
        .Range("E2").Resize(K, dU2) = dArr
    End If
End With
End Sub

 

[HUONGHCKT]

Anh/chị cho em hỏi mình có cách nào tách dữ liệu thành nhiều dòng dựa theo điều kiện.
Vd: E có 1 bảng "data" vào như file đính kèm, tương ứng điều kiện của "number_subject", sẽ hiển thị kết quả tương ứng như sheet "result".

Dùng thử code này xem sao.

Sub ABC()
Dim i&, j&, t&, k&, tong&, lr&
Dim Arr(), KQ()
With Sheets("data")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A1:D" & lr).Value
tong = Application.Sum(.Range("D2:D" & lr))
End With
ReDim KQ(1 To tong + 1, 1 To 3)
k = 1
KQ(k, 1) = Arr(1, 1)
KQ(k, 2) = Arr(1, 2)
KQ(k, 3) = Arr(1, 3)
For i = 2 To UBound(Arr)
    If IsNumeric(Arr(i, 4)) Then t = Arr(i, 4)
        For j = 1 To t
            k = k + 1
            KQ(k, 1) = Arr(i, 1)
            KQ(k, 2) = Arr(i, 2)
            KQ(k, 3) = Arr(i, 3)
        Next j
Next i
If k Then
Sheets("result").[A1].Resize(k, 3).ClearContents
Sheets("result").[A1].Resize(k, 3) = KQ
End If
MsgBox "Xong"
End Sub
[\Code]

 

[Nhattanktnn]

Dùng thử code này xem sao.

Sub ABC()
Dim i&, j&, t&, k&, tong&, lr&
Dim Arr(), KQ()
With Sheets("data")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A1:D" & lr).Value
tong = Application.Sum(.Range("D2:D" & lr))
End With
ReDim KQ(1 To tong + 1, 1 To 3)
k = 1
KQ(k, 1) = Arr(1, 1)
KQ(k, 2) = Arr(1, 2)
KQ(k, 3) = Arr(1, 3)
For i = 2 To UBound(Arr)
    If IsNumeric(Arr(i, 4)) Then t = Arr(i, 4)
        For j = 1 To t
            k = k + 1
            KQ(k, 1) = Arr(i, 1)
            KQ(k, 2) = Arr(i, 2)
            KQ(k, 3) = Arr(i, 3)
        Next j
Next i
If k Then
Sheets("result").[A1].Resize(k, 3).ClearContents
Sheets("result").[A1].Resize(k, 3) = KQ
End If
MsgBox "Xong"
End Sub
[\Code]

Cho phép mình góp ý với code bạn tí nhé,
1/ Mình có thể cho arr(1,4)=1 từ đầu luôn thì đỡ phải ghi KQ nhiều lần
2/ Chỗ resize(k,3).clearcontents đó chưa hợp lý. Nếu dữ liệu ban đầu dài hơn, xóa như vậy vẫn sót dữ liệu cũ
Code mình sửa chút nó như này:

Sub ABC()
Dim i&, j&, t&, k&, tong&, lr&
Dim Arr(), KQ()
With Sheets("data")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A1:D" & lr).Value
Arr(1, 4) = 1
tong = Application.Sum(.Range("D2:D" & lr))
End With
ReDim KQ(1 To tong + 1, 1 To 3)
For i = 1 To UBound(Arr)
    If IsNumeric(Arr(i, 4)) Then t = Arr(i, 4)
        For j = 1 To t
            k = k + 1
            KQ(k, 1) = Arr(i, 1)
            KQ(k, 2) = Arr(i, 2)
            KQ(k, 3) = Arr(i, 3)
        Next j
Next i
If k Then
Sheets("result").[A1].Resize(Rows.Count, 3).ClearContents
Sheets("result").[A1].Resize(k, 3) = KQ
End If
MsgBox "Xong"
End Sub

 

[Hoàng Tuấn 868]

Anh/chị cho em hỏi mình có cách nào tách dữ liệu thành nhiều dòng dựa theo điều kiện.
Vd: E có 1 bảng "data" vào như file đính kèm, tương ứng điều kiện của "number_subject", sẽ hiển thị kết quả tương ứng như sheet "result".

Bạn tham khảo với cách dùng công thức.

 

[HUONGHCKT]

Cho phép mình góp ý với code bạn tí nhé,
1/ Mình có thể cho arr(1,4)=1 từ đầu luôn thì đỡ phải ghi KQ nhiều lần
2/ Chỗ resize(k,3).clearcontents đó chưa hợp lý. Nếu dữ liệu ban đầu dài hơn, xóa như vậy vẫn sót dữ liệu cũ
Code mình sửa chút nó như này:

Sub ABC()
Dim i&, j&, t&, k&, tong&, lr&
Dim Arr(), KQ()
With Sheets("data")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
Arr = .Range("A1:D" & lr).Value
Arr(1, 4) = 1
tong = Application.Sum(.Range("D2:D" & lr))
End With
ReDim KQ(1 To tong + 1, 1 To 3)
For i = 1 To UBound(Arr)
    If IsNumeric(Arr(i, 4)) Then t = Arr(i, 4)
        For j = 1 To t
            k = k + 1
            KQ(k, 1) = Arr(i, 1)
            KQ(k, 2) = Arr(i, 2)
            KQ(k, 3) = Arr(i, 3)
        Next j
Next i
If k Then
Sheets("result").[A1].Resize(Rows.Count, 3).ClearContents
Sheets("result").[A1].Resize(k, 3) = KQ
End If
MsgBox "Xong"
End Sub

Cảm ơn anh đã xem bài và chỉ giáo.
1/ anh thay Arr(i,4)=1 đã rút gọn được code rất nhiều: không phải k=0; không phải ghi dòng tiêu đề.
2/ Tôi chỉ nghĩ là xóa dũ liệu cũ qua mỗi lần chay code chứ chưa nghĩ đến xóa toàn bộ dữ liệu cột A:C để gán kết quả vào.
Thật đúng là tầm chuyên gia VBA có khác. Anh đã cho tôi và nhiều bạn mới học VBA một kinh nghiệm quý báu.

 

[Nhattanktnn]

Cảm ơn anh đã xem bài và chỉ giáo.
1/ anh thay Arr(i,4)=1 đã rút gọn được code rất nhiều: không phải k=0; không phải ghi dòng tiêu đề.
2/ Tôi chỉ nghĩ là xóa dũ liệu cũ qua mỗi lần chay code chứ chưa nghĩ đến xóa toàn bộ dữ liệu cột A:C để gán kết quả vào.
Thật đúng là tầm chuyên gia VBA có khác. Anh đã cho tôi và nhiều bạn mới học VBA một kinh nghiệm quý báu.

Chời gì khen nức mũi vậy, thật ra mình cũng không khá khẩm gì đâu. Lâu lâu kiểu mèo mù vớ cá rán vậy thôi

 

[be_09]

Anh/chị cho em hỏi mình có cách nào tách dữ liệu thành nhiều dòng dựa theo điều kiện.
Vd: E có 1 bảng "data" vào như file đính kèm, tương ứng điều kiện của "number_subject", sẽ hiển thị kết quả tương ứng như sheet "result".

Thêm một cách khác cho bạn.

 

[dahoydu]

Cám ơn cả nhà nhiều, ko ngờ nhận được nhiều cách khác nhau từ nhiều anh/chị như vậy

 

[HUONGHCKT]

Cám ơn cả nhà nhiều, ko ngờ nhận được nhiều cách khác nhau từ nhiều anh/chị như vậy

Diễn đàn GPE một sân chơi để học, học để chơi cho những ai đam mê VBA nói riêng và EX nói chung mà bạn.