vba tách dòng theo điều kiện

maint123 · 19/9/22

Mọi người giải giúp em đoạn code:
Nếu là TRUE thì tách Open Quantity nhỏ hơn hoặc bằng Check và số lượng Open Quantity được tách ra từng dòng bằng với Open Quantity ban đầu.
Ví dụ: Open Quantity = 161 > Check = 90 --> Kết quả ra TRUE
Tách thành 2 dòng lần lượt: Open Quantity = 90 -->FAlSE
Open quantity = 71 --> FALSE

Vấn đề em đang gặp phải là việc tách thủ công hay bị tách thiếu hoặc thừa open quantity hoặc bị nhầm lẫn sang các dòng phía sau chưa tách, em muốn insert dòng rỗng vào thì VBA sẽ tách theo dòng đó đảm bảo :
Toàn bộ các dòng TRUE được tách về FALSE hết với điều kiện Open Quantity nhỏ hơn hoặc bằng Check và số lượng Open Quantity được tách ra từng dòng bằng với Open Quantity ban đầu.

Trong file đính kèm em có 1 sheet gốc (sheet cần vba để tách hết toàn bộ dòng có TRUE về FALSE) và 1 sheet em có ví dụ mẫu dòng đầu tiên để mọi người hình dung dễ hơn ạ.
Rất mong mọi người hỗ trợ giúp em.
Em cảm ơn mọi người ạ

snow25 · 19/9/22

maint123 đã viết:
Mọi người giải giúp em đoạn code:
Nếu là TRUE thì tách Open Quantity nhỏ hơn hoặc bằng Check và số lượng Open Quantity được tách ra từng dòng bằng với Open Quantity ban đầu.
Ví dụ: Open Quantity = 161 > Check = 90 --> Kết quả ra TRUE
Tách thành 2 dòng lần lượt: Open Quantity = 90 -->FAlSE
Open quantity = 71 --> FALSE

Vấn đề em đang gặp phải là việc tách thủ công hay bị tách thiếu hoặc thừa open quantity hoặc bị nhầm lẫn sang các dòng phía sau chưa tách, em muốn insert dòng rỗng vào thì VBA sẽ tách theo dòng đó đảm bảo :
Toàn bộ các dòng TRUE được tách về FALSE hết với điều kiện Open Quantity nhỏ hơn hoặc bằng Check và số lượng Open Quantity được tách ra từng dòng bằng với Open Quantity ban đầu.

Trong file đính kèm em có 1 sheet gốc (sheet cần vba để tách hết toàn bộ dòng có TRUE về FALSE) và 1 sheet em có ví dụ mẫu dòng đầu tiên để mọi người hình dung dễ hơn ạ.
Rất mong mọi người hỗ trợ giúp em.
Em cảm ơn mọi người ạ

Đổi tên sheet thành sheet goc và sheet tach rồi chạy code

Mã:

Sub abc()
Dim i As Long, lr As Long, kq, arr, a As Long, b As Long, c As Long, k As Integer, j As Integer
With Sheets("sheet goc")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:Q" & lr).Value
        ReDim kq(1 To UBound(arr) * 10, 1 To 17)
        For i = 1 To UBound(arr)
            b = arr(i, 2) \ arr(i, 16)
            c = arr(i, 2) - arr(i, 16) * b
            For k = 1 To b
                a = a + 1
                For j = 1 To 17
                    kq(a, j) = arr(i, j)
                Next j
                    kq(a, 2) = arr(i, 16)
                    kq(i, 17) = "FALSE"
            Next k
            If c Then
               a = a + 1
                For j = 1 To 17
                    kq(a, j) = arr(i, j)
                Next j
                    kq(a, 2) = c
                    kq(i, 17) = "FALSE"
            End If
        Next i
End With
With Sheets("Sheet tach")
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr > 1 Then .Range("A2:Q" & lr).ClearContents
     .Range("A2:Q2").Resize(a).Value = kq
End With
End Sub

BuiQuangThuan · 19/9/22

maint123 đã viết:
Rất mong mọi người hỗ trợ giúp em.

Thêm 1 cách khác tham khảo: Thêm 1 sheet KQ

Mã:

Sub XYZ()
    Dim sArr(), Res(), i&, t&, K&, Tmp&, j&, JJ&
    With Sheets("Sheet goc")
        sArr = .Range("A2:P" & .Range("A" & Rows.Count).End(3).Row).Value
    End With
    ReDim Res(1 To UBound(sArr) * 10, 1 To UBound(sArr, 2))
    For i = 1 To UBound(sArr)
        If sArr(i, 2) > sArr(i, 16) Then
            t = Int(sArr(i, 2) / sArr(i, 16)) + 1
            For j = 1 To t
                K = K + 1
                Res(K, 1) = sArr(i, 1)
                If j = t Then
                    Res(K, 2) = sArr(i, 2) Mod sArr(i, 16)
                Else
                    Res(K, 2) = sArr(i, 16)
                End If
                For JJ = 3 To UBound(sArr, 2)
                    Res(K, JJ) = sArr(i, JJ)
                Next
            Next
        Else: K = K + 1
            For JJ = 1 To UBound(sArr, 2)
                Res(K, JJ) = sArr(i, JJ)
            Next
        End If
    Next
    With Sheets("KQ")
        .Range("A2").Resize(K, UBound(sArr, 2)).Value = Res
    End With
End Sub

maint123 · 19/9/22

snow25 đã viết:

Đổi tên sheet thành sheet goc và sheet tach rồi chạy code

Mã:

Sub abc()
Dim i As Long, lr As Long, kq, arr, a As Long, b As Long, c As Long, k As Integer, j As Integer
With Sheets("sheet goc")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:Q" & lr).Value
        ReDim kq(1 To UBound(arr) * 10, 1 To 17)
        For i = 1 To UBound(arr)
            b = arr(i, 2) \ arr(i, 16)
            c = arr(i, 2) - arr(i, 16) * b
            For k = 1 To b
                a = a + 1
                For j = 1 To 17
                    kq(a, j) = arr(i, j)
                Next j
                    kq(a, 2) = arr(i, 16)
                    kq(i, 17) = "FALSE"
            Next k
            If c Then
               a = a + 1
                For j = 1 To 17
                    kq(a, j) = arr(i, j)
                Next j
                    kq(a, 2) = c
                    kq(i, 17) = "FALSE"
            End If
        Next i
End With
With Sheets("Sheet tach")
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr > 1 Then .Range("A2:Q" & lr).ClearContents
     .Range("A2:Q2").Resize(a).Value = kq
End With
End Sub

snow25 đã viết:

Đổi tên sheet thành sheet goc và sheet tach rồi chạy code

Mã:

Sub abc()
Dim i As Long, lr As Long, kq, arr, a As Long, b As Long, c As Long, k As Integer, j As Integer
With Sheets("sheet goc")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:Q" & lr).Value
        ReDim kq(1 To UBound(arr) * 10, 1 To 17)
        For i = 1 To UBound(arr)
            b = arr(i, 2) \ arr(i, 16)
            c = arr(i, 2) - arr(i, 16) * b
            For k = 1 To b
                a = a + 1
                For j = 1 To 17
                    kq(a, j) = arr(i, j)
                Next j
                    kq(a, 2) = arr(i, 16)
                    kq(i, 17) = "FALSE"
            Next k
            If c Then
               a = a + 1
                For j = 1 To 17
                    kq(a, j) = arr(i, j)
                Next j
                    kq(a, 2) = c
                    kq(i, 17) = "FALSE"
            End If
        Next i
End With
With Sheets("Sheet tach")
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr > 1 Then .Range("A2:Q" & lr).ClearContents
     .Range("A2:Q2").Resize(a).Value = kq
End With
End Sub

Em cảm ơn ạ, em đã chạy thử và thấy rất ổn ạ

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

BuiQuangThuan đã viết:

Thêm 1 cách khác tham khảo: Thêm 1 sheet KQ

Mã:

Sub XYZ()
    Dim sArr(), Res(), i&, t&, K&, Tmp&, j&, JJ&
    With Sheets("Sheet goc")
        sArr = .Range("A2:P" & .Range("A" & Rows.Count).End(3).Row).Value
    End With
    ReDim Res(1 To UBound(sArr) * 10, 1 To UBound(sArr, 2))
    For i = 1 To UBound(sArr)
        If sArr(i, 2) > sArr(i, 16) Then
            t = Int(sArr(i, 2) / sArr(i, 16)) + 1
            For j = 1 To t
                K = K + 1
                Res(K, 1) = sArr(i, 1)
                If j = t Then
                    Res(K, 2) = sArr(i, 2) Mod sArr(i, 16)
                Else
                    Res(K, 2) = sArr(i, 16)
                End If
                For JJ = 3 To UBound(sArr, 2)
                    Res(K, JJ) = sArr(i, JJ)
                Next
            Next
        Else: K = K + 1
            For JJ = 1 To UBound(sArr, 2)
                Res(K, JJ) = sArr(i, JJ)
            Next
        End If
    Next
    With Sheets("KQ")
        .Range("A2").Resize(K, UBound(sArr, 2)).Value = Res
    End With
End Sub

Em cảm ơn sự hỗ trợ của anh ạ, em cũng chạy thêm cả cách này và thấy kết quả trả về đúng điều kiện ạ

vba tách dòng theo điều kiện

maint123

Thành viên mới

File đính kèm

snow25

Thành viên gạo cội

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

maint123

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng