Tách dữ liệu sang sheet khác theo điều kiện

Liên hệ QC

Bienhoa84

Thành viên mới
Tham gia
5/4/22
Bài viết
28
Được thích
32
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ị!
1663895015387.png
 

File đính kèm

  • GPE.xlsx
    30.1 KB · Đọc: 10

snow25

Thành viên gắn bó
Tham gia
24/7/18
Bài viết
3,173
Được thích
3,185
Donate (Momo)
Donate
Giới tính
Nam
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.
Mã:
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
 
Lần chỉnh sửa cuối:
Upvote 0

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆
Tham gia
17/12/10
Bài viết
1,727
Được thích
1,660
Giới tính
Nam
Thêm 1 cách khác tham khảo:
Mã:
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
 
Lần chỉnh sửa cuối:
Upvote 0

Nhattanktnn

Thành viên gắn bó
Tham gia
11/11/16
Bài viết
2,504
Được thích
2,917
Donate (Momo)
Donate
Giới tính
Nam
Thử code.
Mã:
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
 
Upvote 0

Nhattanktnn

Thành viên gắn bó
Tham gia
11/11/16
Bài viết
2,504
Được thích
2,917
Donate (Momo)
Donate
Giới tính
Nam
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
 
Upvote 0

snow25

Thành viên gắn bó
Tham gia
24/7/18
Bài viết
3,173
Được thích
3,185
Donate (Momo)
Donate
Giới tính
Nam
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
 
Upvote 0
Web KT

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL
Top Bottom