VBA tách dòng tổng thành các dòng phụ (5 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
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

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

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

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

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

Vu_Thi_Xuan
Lỗi tham chiếu khi dùng Vlookup trong VBA (1 người xem)
Trả lời
7
Đọc
260
SA_DQ
SA_DQ
6
  • Question Question
vba tự động lấy dữ liệu từ etabs (2 người xem)
Trả lời
2
Đọc
87
VetMini
V
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ (2 người xem)
2
Trả lời
20
Đọc
669
198zxc
1
D
Nhờ anh chị xử lý giúp lỗi thực hiện lọc dữ liệu (1 người xem)
Trả lời
2
Đọc
46
Hoàng Tuấn 868
H
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (3 người xem)
    • Thích
2 3
Trả lời
50
Đọc
5K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
xin các cao thủ chỉ cách gỡ lỗi không khởi động được excel
Trả lời
4
Đọc
242
bs2
B
H
Chuyển file *xml hóa đơn điện tử sang excel
    • Thích
Trả lời
10
Đọc
445
htrunga2
H
D
Nhờ anh chị trên diễn đàn dùng hàm dò tìm dữ liệu trong bảng gửi kèm giúp ạ! (1 người xem)
Trả lời
4
Đọc
127
dangvanphu.it
D
P
Phát âm thanh tiếng việt cho dữ liệu trong file excel
Trả lời
3
Đọc
159
PNQC
P
E
Giúp em tạo gợi ý trong combobox sau khi đã lọc danh sách duy nhất trong combobox đó
Trả lời
11
Đọc
3K
thepkun8x
T
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
1
Đọc
4K
GPE-Trợ Lý
GPE-Trợ Lý
queluatb
  • Question Question
Lấy hóa đơn đầu vào cho hóa đơn đầu ra
Trả lời
3
Đọc
252
queluatb
queluatb
C
Tính tổng một khách hàng có nhiều mã hàng nhỏ (1 người xem)
2
Trả lời
21
Đọc
382
Phuocam
Phuocam
G
Làm sao để sắp xếp nhiều cột và hàng theo abc vậy ạ ?
Trả lời
9
Đọc
263
Duy Tùng 9x
Duy Tùng 9x
K
Lỗi chèn ảnh hàng loạt trong excel 2024 (1 người xem)
Trả lời
2
Đọc
139
kenytien
K
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM (2 người xem)
    • Thích
Trả lời
2
Đọc
1K
ptm0412
ptm0412
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table (1 người xem)
Trả lời
10
Đọc
416
VetMini
V
P
Xin tư vấn về cách tạo bảng quản lý vải
    • Cười
Trả lời
16
Đọc
361
pycckuu410
pycckuu410
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
349
Đọc
32K
tuanktt3
T
D
Nhờ các bác giúp đỡ vấn đề tìm kiếm dữ liệu
Trả lời
6
Đọc
236
Hoàng Tuấn 868
H
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom