Tách dữ liệu sang sheet khác theo điều kiện (4 người xem)

[Ronaldinho7]

Xin chào Anh/Chị
Nhờ anh/chị code dùm để tách dữ liệu qua các sheet theo điều kiện tổng giờ nhỏ hơn (gần nhất) 300 giờ theo mô tả phía dưới.
Xin chân thành cảm ơn anh/chị!

 

[snow25]

Xin chào Anh/Chị
Nhờ anh/chị code dùm để tách dữ liệu qua các sheet theo điều kiện tổng giờ nhỏ hơn (gần nhất) 300 giờ theo mô tả phía dưới.
Xin chân thành cảm ơn anh/chị!
View attachment 281258

Thử code.

Sub abc()
    Dim i As Long, lr As Long, sh As Worksheet, arr, kq, sogio As Double, b As Long, a As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    b = 300
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "tong" Then
            sh.Delete
        End If
    Next sh
    With Sheets("tong")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("D4:E" & lr).Value
        ReDim kq(1 To UBound(arr)+1, 1 To 2)
        kq(1, 1) = "Ma hang"
        kq(1, 2) = "so gio"
        a = 1
        For i = 1 To UBound(arr)
            sogio = sogio + arr(i, 2)
            If sogio > b Then
               Set sh = Worksheets.Add
               sh.Range("D3:E3").Resize(a).Value = kq
               Erase kq
               ReDim kq(1 To UBound(arr), 1 To 2)
               a = 1: sogio = arr(i, 2)
               kq(1, 1) = "Ma hang"
               kq(1, 2) = "so gio"
            End If
            a = a + 1
            kq(a, 1) = arr(i, 1)
            kq(a, 2) = arr(i, 2)
        Next i
        If a Then
           Set sh = Worksheets.Add
           sh.Range("D3:E3").Resize(a).Value = kq
        End If
   End With
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub

 

[BuiQuangThuan]

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

Sub ABC()
    Dim Ws As Worksheet, sArr(), Res(), i&, Temp As Double
    Dim K&, n%
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name <> "tong" Then
            Ws.Delete
        End If
    Next
    If Application.WorksheetFunction.Sum(Sheets("tong").Range("E:E")) > 300 Then
        sArr = Sheets("tong").Range("D4:E" & Sheets("tong").Range("D" & Rows.Count).End(3).Row).Value
        ReDim Res(1 To UBound(sArr), 1 To 2)
        Res(1, 1) = Sheets("tong").Range("D3").Value
        Res(1, 2) = Sheets("tong").Range("E3").Value: K = 1
        For i = 1 To UBound(sArr)
            K = K + 1
            Temp = Temp + sArr(i, 2)
            Res(K, 1) = sArr(i, 1)
            Res(K, 2) = sArr(i, 2)
            If Temp > 300 Then
                i = i - 1: n = n + 1
                Worksheets.Add after:=Sheets(Sheets.Count)
                ActiveSheet.Name = "Sheet" & n
                ActiveSheet.Range("D3").Resize(K - 1, 2) = Res
                K = 1: Temp = 0
            End If
        Next
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[Nhattanktnn]

Thử code.

Sub abc()
    Dim i As Long, lr As Long, sh As Worksheet, arr, kq, sogio As Double, b As Long, a As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    b = 300
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "tong" Then
            sh.Delete
        End If
    Next sh
    With Sheets("tong")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        arr = .Range("D4:E" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 2)
        kq(1, 1) = "Ma hang"
        kq(1, 2) = "so gio"
        a = 1
        For i = 1 To UBound(arr)
            sogio = sogio + arr(i, 2)
            If sogio > b Then
               Set sh = Worksheets.Add
               sh.Range("D3:E3").Resize(a).Value = kq
               Erase kq
               ReDim kq(1 To UBound(arr), 1 To 2)
               a = 1: sogio = arr(i, 2)
               kq(1, 1) = "Ma hang"
               kq(1, 2) = "so gio"
            End If
            a = a + 1
            kq(a, 1) = arr(i, 1)
            kq(a, 2) = arr(i, 2)
        Next i
        If a Then
           Set sh = Worksheets.Add
           sh.Range("D3:E3").Resize(a).Value = kq
        End If
   End With
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub

Nếu chỉ có một sheet duy nhất, tức tổng <300 thì redim kq bị thiếu

 

[snow25]

Nếu chỉ có một sheet duy nhất, tức tổng <300 thì redim kq bị thiếu

Bạn thử code chưa mình viết xong không thử à.

 

[Nhattanktnn]

Bạn thử code chưa mình viết xong không thử à.

Mình thử rồi, nhưng xem qua cũng thấy thôi. arr không lấy tiêu đề, còn kq thì dòng đầu ghi tiêu đề nhưng tổng dòng cũng chỉ bằng ubound(arr). Mà nói vậy thôi chứ có 1 sheet thì chắc không ai tách hihi

 

[snow25]

Mình thử rồi, nhưng xem qua cũng thấy thôi. arr không lấy tiêu đề, còn kq thì dòng đầu ghi tiêu đề nhưng tổng dòng cũng chỉ bằng ubound(arr). Mà nói vậy thôi chứ có 1 sheet thì chắc không ai tách hihi

À mình vừa vào test code thiếu +1

 

[Ronaldinho7]

Rất cám ơn bác @snow25 @BuiQuangThuan và bác @Nhattanktnn đã nhiệt tình giúp đỡ nhé!
Chúc mọi người một ngày vui!