VBA tách dòng tổng thành các dòng phụ

Liên hệ QC
tranthuy28190

tranthuy28190

Thành viên mới
Tham gia
13/10/22
Bài viết
26
Được thích
7
Nhờ các cao nhân chỉ dạy giúp em có tool nào có thể tách dòng tổng thành các dòng phụ.
Như trong file đính kèm thì có sheet "Đề bài" và sheet "kết quả mong muốn".
Ví dụ: tổng là 25,000 tách thành 5 dòng số lượng 5,000. Và khi run tool thì các dòng đó khi chạy xuống sẽ không đè vào dòng đang có sẵn.

Cảm ơn các cao nhân!
 

File đính kèm

  • Tách dòng.xlsx
    11.9 KB · Đọc: 26
Làm tạm cái code này.
Nhấn vào nút "TÁCH" nhé
Mã: 
Option Explicit
Sub tach()
Dim lr&, i&, j&, t&, k&, c&, rng, arr(1 To 100000, 1 To 9)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
    For i = 1 To UBound(rng)
        c = Int(rng(i, 7) / rng(i, 8))
        For t = 1 To c
            k = k + 1
            For j = 1 To 8
                arr(k, j) = rng(i, j)
            Next
            If t > 1 Then
                arr(k, 1) = "": arr(k, 4) = 0: arr(k, 7) = 0
            End If
            arr(k, 9) = "ROHM"
        Next
    Next
End With
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:H1").Value = Sheets("Sheet1").Range("A1:H1").Value
Range("I1").Value = "Maker"
Range("A2:I100000").ClearContents
Range("A2").Resize(k, 9).Value = arr
Range("A2:I2").EntireColumn.AutoFit
End Sub
 

File đính kèm

  • Tách dòng.xlsm
    21.1 KB · Đọc: 21
tranthuy28190 đã viết:
Nhờ các cao nhân chỉ dạy giúp em có tool nào có thể tách dòng tổng thành các dòng phụ.
Như trong file đính kèm thì có sheet "Đề bài" và sheet "kết quả mong muốn".
Ví dụ: tổng là 25,000 tách thành 5 dòng số lượng 5,000. Và khi run tool thì các dòng đó khi chạy xuống sẽ không đè vào dòng đang có sẵn.

Cảm ơn các cao nhân!
Nhấp chuột vào đây để mở rộng...
Phải công nhận là có nhiều nhu cầu lạ ghê. Thêm một cách cho bạn tham khảo. Max là 100 000 dòng. Nếu nhiều hơn sửa số 100 000 theo nhu cầu thực tế
Mã: 
Sub Tach_Dong()
Dim sArr(), dArr(), i As Long, k As Long, j As Long, n As Long
With Sheet1
   sArr = .Range("A2", .Range("A65536").End(3)).Resize(, 8).Value
End With
ReDim dArr(1 To 100000, 1 To UBound(sArr, 2) + 1)
For i = 1 To UBound(sArr)
   k = k + 1
   For j = 1 To UBound(sArr, 2)
      dArr(k, j) = sArr(i, j)
   Next
   dArr(k, 9) = "ABC"
   For n = 2 To sArr(i, 7) / sArr(i, 8)
      k = k + 1
      dArr(k, 2) = sArr(i, 2)
      dArr(k, 3) = sArr(i, 3)
      dArr(k, 5) = sArr(i, 5)
      dArr(k, 6) = sArr(i, 6)
      dArr(k, 8) = sArr(i, 8)
      dArr(k, 9) = "ABC"
   Next
Next
Sheet2.Range("J2").Resize(k, UBound(dArr, 2)) = dArr
End Sub
 
bebo021999 đã viết:
Làm tạm cái code này.
Nhấn vào nút "TÁCH" nhé
Mã: 
Option Explicit
Sub tach()
Dim lr&, i&, j&, t&, k&, c&, rng, arr(1 To 100000, 1 To 9)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
    For i = 1 To UBound(rng)
        c = Int(rng(i, 7) / rng(i, 8))
        For t = 1 To c
            k = k + 1
            For j = 1 To 8
                arr(k, j) = rng(i, j)
            Next
            If t > 1 Then
                arr(k, 1) = "": arr(k, 4) = 0: arr(k, 7) = 0
            End If
            arr(k, 9) = "ROHM"
        Next
    Next
End With
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:H1").Value = Sheets("Sheet1").Range("A1:H1").Value
Range("I1").Value = "Maker"
Range("A2:I100000").ClearContents
Range("A2").Resize(k, 9).Value = arr
Range("A2:I2").EntireColumn.AutoFit
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác nhiều, em làm được rồi ạ
Bài đã được tự động gộp:

Quang_Hải đã viết:
Phải công nhận là có nhiều nhu cầu lạ ghê. Thêm một cách cho bạn tham khảo. Max là 100 000 dòng. Nếu nhiều hơn sửa số 100 000 theo nhu cầu thực tế
Mã: 
Sub Tach_Dong()
Dim sArr(), dArr(), i As Long, k As Long, j As Long, n As Long
With Sheet1
   sArr = .Range("A2", .Range("A65536").End(3)).Resize(, 8).Value
End With
ReDim dArr(1 To 100000, 1 To UBound(sArr, 2) + 1)
For i = 1 To UBound(sArr)
   k = k + 1
   For j = 1 To UBound(sArr, 2)
      dArr(k, j) = sArr(i, j)
   Next
   dArr(k, 9) = "ABC"
   For n = 2 To sArr(i, 7) / sArr(i, 8)
      k = k + 1
      dArr(k, 2) = sArr(i, 2)
      dArr(k, 3) = sArr(i, 3)
      dArr(k, 5) = sArr(i, 5)
      dArr(k, 6) = sArr(i, 6)
      dArr(k, 8) = sArr(i, 8)
      dArr(k, 9) = "ABC"
   Next
Next
Sheet2.Range("J2").Resize(k, UBound(dArr, 2)) = dArr
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác nhé. Hi, vì nhu cầu công việc nên cũng nhiều yêu cầu oái oăm lắm ạ
 
bebo021999 đã viết:
Làm tạm cái code này.
Nhấn vào nút "TÁCH" nhé
Mã: 
Option Explicit
Sub tach()
Dim lr&, i&, j&, t&, k&, c&, rng, arr(1 To 100000, 1 To 9)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
    For i = 1 To UBound(rng)
        c = Int(rng(i, 7) / rng(i, 8))
        For t = 1 To c
            k = k + 1
            For j = 1 To 8
                arr(k, j) = rng(i, j)
            Next
            If t > 1 Then
                arr(k, 1) = "": arr(k, 4) = 0: arr(k, 7) = 0
            End If
            arr(k, 9) = "ROHM"
        Next
    Next
End With
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:H1").Value = Sheets("Sheet1").Range("A1:H1").Value
Range("I1").Value = "Maker"
Range("A2:I100000").ClearContents
Range("A2").Resize(k, 9).Value = arr
Range("A2:I2").EntireColumn.AutoFit
End Sub
Nhấp chuột vào đây để mở rộng...
bác ơi, em hỏi thêm 1 chút ạ.
Nếu số lượng chia ra bị lẻ thì có cách nào để số lẻ đó ở dòng cuối cùng, thay vì là số lượng đơn vị chẵn như vba của bác?

1665723115177.png
 

File đính kèm

  • Tách dòng.xlsm
    22.2 KB · Đọc: 3
Thử lại nhé:
PHP: 
Option Explicit
Sub tach()
Dim lr&, i&, j&, t&, k&, c&, c1&, rng, arr(1 To 100000, 1 To 9)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
    For i = 1 To UBound(rng)
        c = Int(rng(i, 7) / rng(i, 8))
        c1 = rng(i, 7) - rng(i, 8) * c
        For t = 1 To IIf(c1 = 0, c, c + 1)
            k = k + 1
            For j = 1 To 8
                arr(k, j) = rng(i, j)
                If j = 8 And t = c + 1 Then arr(k, j) = c1
            Next
            If t > 1 Then
                arr(k, 1) = "": arr(k, 4) = 0: arr(k, 7) = 0
            End If
            arr(k, 9) = "ROHM"
        Next
    Next
End With
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:H1").Value = Sheets("Sheet1").Range("A1:H1").Value
Range("I1").Value = "Maker"
Range("A2:I100000").ClearContents
Range("A2").Resize(k, 9).Value = arr
Range("A2:I2").EntireColumn.AutoFit
End Sub
 

File đính kèm

  • Tách dòng (1).xlsm
    17.7 KB · Đọc: 21
bebo021999 đã viết:
Thử lại nhé:
PHP: 
Option Explicit
Sub tach()
Dim lr&, i&, j&, t&, k&, c&, c1&, rng, arr(1 To 100000, 1 To 9)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
    For i = 1 To UBound(rng)
        c = Int(rng(i, 7) / rng(i, 8))
        c1 = rng(i, 7) - rng(i, 8) * c
        For t = 1 To IIf(c1 = 0, c, c + 1)
            k = k + 1
            For j = 1 To 8
                arr(k, j) = rng(i, j)
                If j = 8 And t = c + 1 Then arr(k, j) = c1
            Next
            If t > 1 Then
                arr(k, 1) = "": arr(k, 4) = 0: arr(k, 7) = 0
            End If
            arr(k, 9) = "ROHM"
        Next
    Next
End With
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:H1").Value = Sheets("Sheet1").Range("A1:H1").Value
Range("I1").Value = "Maker"
Range("A2:I100000").ClearContents
Range("A2").Resize(k, 9).Value = arr
Range("A2:I2").EntireColumn.AutoFit
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác ạ, quá tuyệt vời :D
 
bebo021999 đã viết:
Thử lại nhé:
PHP: 
Option Explicit
Sub tach()
Dim lr&, i&, j&, t&, k&, c&, c1&, rng, arr(1 To 100000, 1 To 9)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
    For i = 1 To UBound(rng)
        c = Int(rng(i, 7) / rng(i, 8))
        c1 = rng(i, 7) - rng(i, 8) * c
        For t = 1 To IIf(c1 = 0, c, c + 1)
            k = k + 1
            For j = 1 To 8
                arr(k, j) = rng(i, j)
                If j = 8 And t = c + 1 Then arr(k, j) = c1
            Next
            If t > 1 Then
                arr(k, 1) = "": arr(k, 4) = 0: arr(k, 7) = 0
            End If
            arr(k, 9) = "ROHM"
        Next
    Next
End With
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:H1").Value = Sheets("Sheet1").Range("A1:H1").Value
Range("I1").Value = "Maker"
Range("A2:I100000").ClearContents
Range("A2").Resize(k, 9).Value = arr
Range("A2:I2").EntireColumn.AutoFit
End Sub
Nhấp chuột vào đây để mở rộng...
bác ơi, em muốn sửa lại đoạn code: thay vì chỉ giới hạn trong 8 cột, mở rộng ra khoảng 20 cột được không ạ? Cột 7 và cột 8 thì vẫn chia theo số lượng như thế, cột 9 trở đi thì giống cột 1-6 (tách dòng copy nội dung của dòng chính xuống các dòng phụ).
Em cảm ơn bác nhiều!
 
bebo021999 đã viết:
Thử lại nhé:
PHP: 
Option Explicit
Sub tach()
Dim lr&, i&, j&, t&, k&, c&, c1&, rng, arr(1 To 100000, 1 To 9)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
    For i = 1 To UBound(rng)
        c = Int(rng(i, 7) / rng(i, 8))
        c1 = rng(i, 7) - rng(i, 8) * c
        For t = 1 To IIf(c1 = 0, c, c + 1)
            k = k + 1
            For j = 1 To 8
                arr(k, j) = rng(i, j)
                If j = 8 And t = c + 1 Then arr(k, j) = c1
            Next
            If t > 1 Then
                arr(k, 1) = "": arr(k, 4) = 0: arr(k, 7) = 0
            End If
            arr(k, 9) = "ROHM"
        Next
    Next
End With
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1:H1").Value = Sheets("Sheet1").Range("A1:H1").Value
Range("I1").Value = "Maker"
Range("A2:I100000").ClearContents
Range("A2").Resize(k, 9).Value = arr
Range("A2:I2").EntireColumn.AutoFit
End Sub
Nhấp chuột vào đây để mở rộng...
bác ơi, bác trả lời giúp em tin nhắn trên với ạ:
bác ơi, em muốn sửa lại đoạn code: thay vì chỉ giới hạn trong 8 cột, mở rộng ra khoảng 20 cột được không ạ? Cột 7 và cột 8 thì vẫn chia theo số lượng như thế, cột 9 trở đi thì giống cột 1-6 (tách dòng copy nội dung của dòng chính xuống các dòng phụ).
Em cảm ơn bác nhiều!
 
Gửi lại file mới có 20 cột đi bạn. Nhập tay kết quả mong muốn nhé.
 
Quang_Hải đã viết:
Phải công nhận là có nhiều nhu cầu lạ ghê. ...
Nhấp chuột vào đây để mở rộng...
Không phải "nhu cầu", mà là "yêu cầu".
Không phải người ta bắt buộc phải làm như vậy. Chỉ vì làm thử chả có tốn công sức (công của bạn), và chi phí (máy công ty) cho nên người ta tha hồ thử xem sao.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

kiencuong030184
  • Question
Nhờ giúp đỡ về ẩn dòng, cột có điều kiện
Trả lời
1
Đọc
20
BuiQuangThuan
B
T
V/v tối ưu xử lý đoạn code
Trả lời
1
Đọc
35
SA_DQ
SA_DQ
kiet317
Helloooooooooooo
    • Phẫn nộ
    • Buồn
Trả lời
1
Đọc
24
Hoàng Tuấn 868
H
H
  • Question
Code subtotal và tìm điều kiện
Trả lời
9
Đọc
104
Hoàng Tuấn 868
H
Emyeuexcel
  • Question
In theo số thứ tự
    • Chấp nhận
Trả lời
7
Đọc
139
yaaasoo01
Y
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom