Hỏi cách chia file excel ra nhiều file theo điều kiện tổng (1 người xem)

vnkiss1 · 10/9/19

Em chào các bác,

Em có 1 file excel khoảng 3000 dòng, em đang tìm cách để tách ra nhiều file nhưng vẫn chưa ra

Tách theo điều kiện tổng tiền hàng 1 file tầm 1 tỷ

Ví dụ: Từ khách 1 đến khách 30 được 1 tỷ sẽ chia ra 1 file
Tiếp tục từ khách 31 đến khách 45 được 1 tỷ chia ra 1 file
....

Nhờ các bác giúp em với ạ.

Em cảm ơn.

snow25 · 10/9/19

vnkiss1 đã viết:
Em chào các bác,

Em có 1 file excel khoảng 3000 dòng, em đang tìm cách để tách ra nhiều file nhưng vẫn chưa ra

Tách theo điều kiện tổng tiền hàng 1 file tầm 1 tỷ

Ví dụ: Từ khách 1 đến khách 30 được 1 tỷ sẽ chia ra 1 file
Tiếp tục từ khách 31 đến khách 45 được 1 tỷ chia ra 1 file
....

Nhờ các bác giúp em với ạ.

Em cảm ơn.

Tốt nhất bạn đưa file thực tế lên.Ví dụ của bạn không ổn lắm.Tại bạn nói 1 tỷ thế nó không bằng thì sao.Mà ở trong file có bằng đâu.Mà chia xong đặt tên kiểu gì.

vnkiss1 · 10/9/19

Dạ chào bác Snow25,

Xin lỗi bác, em ghi hơi sai, chia file với tổng tiền hàng bé hơn 1 tỷ và lớn hơn 900 triệu

Tên file chỉ cần đặt theo số thứ tự 1, 2, 3 thôi ạ.

snow25 · 10/9/19

vnkiss1 đã viết:
Dạ chào bác Snow25,

Xin lỗi bác, em ghi hơi sai, chia file với tổng tiền hàng bé hơn 1 tỷ và lớn hơn 900 triệu

Tên file chỉ cần đặt theo số thứ tự 1, 2, 3 thôi ạ.

Bạn thử.

Mã:

Sub chiafile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Const tien As Double = 1000000000
    Dim arr, i As Long, lr As Long, tong As Double, kq, R As Long, a As Long, b As Long, ws As Workbook, c As Long
    With Sheets("sheet1")
         lr = .Range("b" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("A1:B" & lr).Value
         R = UBound(arr)
         a = 2
    End With
     Do
         ReDim kq(1 To R, 1 To 2)
         tong = 0
         b = 1
         kq(1, 1) = arr(1, 1)
         kq(1, 2) = arr(1, 2)
         For i = a To R
             tong = tong + arr(i, 2)
             If tong < tien Then
                b = b + 1
                a = a + 1
                kq(b, 1) = arr(i, 1)
                kq(b, 2) = arr(i, 2)
             Else
                Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
                Exit For
            End If
         Next i
         If tong < tien Then
             Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
         End If
         If a > R Then Exit Do
     Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

HieuCD · 10/9/19

snow25 đã viết:

Bạn thử.

Mã:

Sub chiafile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Const tien As Double = 1000000000
    Dim arr, i As Long, lr As Long, tong As Double, kq, R As Long, a As Long, b As Long, ws As Workbook, c As Long
    With Sheets("sheet1")
         lr = .Range("b" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("A1:B" & lr).Value
         R = UBound(arr)
         a = 2
    End With
     Do
         ReDim kq(1 To R, 1 To 2)
         tong = 0
         b = 1
         kq(1, 1) = arr(1, 1)
         kq(1, 2) = arr(1, 2)
         For i = a To R
             tong = tong + arr(i, 2)
             If tong < tien Then
                b = b + 1
                a = a + 1
                kq(b, 1) = arr(i, 1)
                kq(b, 2) = arr(i, 2)
             Else
                Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
                Exit For
            End If
         Next i
         If tong < tien Then
             Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
         End If
         If a > R Then Exit Do
     Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Thử chỉnh code để bỏ các dòng lệnh

If tong < tien Then
Set ws = Workbooks.Add
c = c + 1
ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
ws.Close
End If
If a > R Then Exit Do

vnkiss1 · 10/9/19

snow25 đã viết:

Bạn thử.

Mã:

Sub chiafile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Const tien As Double = 1000000000
    Dim arr, i As Long, lr As Long, tong As Double, kq, R As Long, a As Long, b As Long, ws As Workbook, c As Long
    With Sheets("sheet1")
         lr = .Range("b" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("A1:B" & lr).Value
         R = UBound(arr)
         a = 2
    End With
     Do
         ReDim kq(1 To R, 1 To 2)
         tong = 0
         b = 1
         kq(1, 1) = arr(1, 1)
         kq(1, 2) = arr(1, 2)
         For i = a To R
             tong = tong + arr(i, 2)
             If tong < tien Then
                b = b + 1
                a = a + 1
                kq(b, 1) = arr(i, 1)
                kq(b, 2) = arr(i, 2)
             Else
                Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
                Exit For
            End If
         Next i
         If tong < tien Then
             Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
         End If
         If a > R Then Exit Do
     Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Cảm ơn bác Snow25 lắm lắm luôn.

snow25 · 10/9/19

HieuCD đã viết:
Thử chỉnh code để bỏ các dòng lệnh
If tong < tien Then
Set ws = Workbooks.Add
c = c + 1
ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
ws.Close
End If
If a > R Then Exit Do

Cái này có được không anh Hiếu.

Mã:

Sub chiafile1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Const tien As Double = 1000000000
    Dim arr, i As Long, lr As Long, tong As Double, kq, R As Long, a As Long, b As Long, ws As Workbook, c As Long
    With Sheets("sheet1")
         lr = .Range("b" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("A1:B" & lr).Value
         R = UBound(arr)
    End With
        ReDim kq(1 To R, 1 To 2)
        tong = 0
        b = 1
        kq(1, 1) = arr(1, 1)
        kq(1, 2) = arr(1, 2)
         For i = 2 To R
             tong = tong + arr(i, 2)
             If tong < tien Then
                b = b + 1
                kq(b, 1) = arr(i, 1)
                kq(b, 2) = arr(i, 2)
             Else
                Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
                ReDim kq(1 To R, 1 To 2)
                tong = 0
                b = 1
                kq(1, 1) = arr(1, 1)
                kq(1, 2) = arr(1, 2)
                i = i - 1
            End If
         Next i
         Set ws = Workbooks.Add
         c = c + 1
         ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
         ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
         ws.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

HieuCD · 10/9/19

snow25 đã viết:

Cái này có được không anh Hiếu.

Mã:

Sub chiafile1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Const tien As Double = 1000000000
    Dim arr, i As Long, lr As Long, tong As Double, kq, R As Long, a As Long, b As Long, ws As Workbook, c As Long
    With Sheets("sheet1")
         lr = .Range("b" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("A1:B" & lr).Value
         R = UBound(arr)
    End With
        ReDim kq(1 To R, 1 To 2)
        tong = 0
        b = 1
        kq(1, 1) = arr(1, 1)
        kq(1, 2) = arr(1, 2)
         For i = 2 To R
             tong = tong + arr(i, 2)
             If tong < tien Then
                b = b + 1
                kq(b, 1) = arr(i, 1)
                kq(b, 2) = arr(i, 2)
             Else
                Set ws = Workbooks.Add
                c = c + 1
                ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
                ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
                ws.Close
                ReDim kq(1 To R, 1 To 2)
                tong = 0
                b = 1
                kq(1, 1) = arr(1, 1)
                kq(1, 2) = arr(1, 2)
                i = i - 1
            End If
         Next i
         Set ws = Workbooks.Add
         c = c + 1
         ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
         ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
         ws.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Gọn hơn rồi, tuy nhiên vẫn còn trùng lệnh
Set ws = Workbooks.Add
c = c + 1
ws.Sheets(1).Range("A1:B1").Resize(b).Value = kq
ws.SaveAs ThisWorkbook.Path & "\" & c & ".xlsx"
ws.Close
Tìm cách bỏ những lệnh ngoài vòng For

Hỏi cách chia file excel ra nhiều file theo điều kiện tổng (1 người xem)

Người dùng đang xem chủ đề này

vnkiss1

Thành viên mới

File đính kèm

snow25

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

vnkiss1

Thành viên mới

snow25

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

HieuCD

Chuyên gia GPE

vnkiss1

Thành viên mới

snow25

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

HieuCD

Chuyên gia GPE

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

Sinh nhật lần 19 GPE