Viết macro tự động tách giá trị theo điều kiện và chèn thêm dòng (1 người xem)

NTNtran · Thứ sáu lúc 13:38

Em có 1 bảng tính vài trăm người và cần xử lý như sau: nếu giá trị tại cột H (cột thứ 8), bắt đầu từ dòng số 5, lớn hơn 500,000,000, thì sẽ tự động tách thành nhiều dòng, mỗi dòng có giá trị 500,000,000, và nếu còn dư thì dòng cuối cùng sẽ chứa phần dư. Các cao nhân giúp em với ạ.

thanthanhan · Thứ sáu lúc 16:34

Bạn dùng thử xem thế nào.

SA_DQ · Thứ sáu lúc 19:56

Nhờ Copilot giúp đây:

PHP:

Function PhanBoTien(SoTien As Double) As Variant
  'Hàm Xài Trong Excel 365   '
    Const DonVi As Double = 500
    ReDim KetQua(1 To 9, 1 To 1) As Double
    Dim SoLan As Integer, Du As Double, i As Integer

    SoLan = Int(SoTien / DonVi)
    Du = SoTien Mod DonVi
    ReDim KetQua(0 To SoLan - 1 + IIf(Du > 0, 1, 0), 1 To 1)

    For i = 0 To SoLan - 1
        KetQua(i, 1) = DonVi
    Next i

    If Du > 0 Then
        KetQua(UBound(KetQua), 1) = Du
    End If
    PhanBoTien = KetQua
End Function

NTNtran · Thứ sáu lúc 22:12

SA_DQ đã viết:

Nhờ Copilot giúp đây:

PHP:

Function PhanBoTien(SoTien As Double) As Variant
  'Hàm Xài Trong Excel 365   '
    Const DonVi As Double = 500
    ReDim KetQua(1 To 9, 1 To 1) As Double
    Dim SoLan As Integer, Du As Double, i As Integer

    SoLan = Int(SoTien / DonVi)
    Du = SoTien Mod DonVi
    ReDim KetQua(0 To SoLan - 1 + IIf(Du > 0, 1, 0), 1 To 1)

    For i = 0 To SoLan - 1
        KetQua(i, 1) = DonVi
    Next i

    If Du > 0 Then
        KetQua(UBound(KetQua), 1) = Du
    End If
    PhanBoTien = KetQua
End Function

Cảm ơn bạn đã trợ giúp, nhưng đoạn mã không chạy được ạ. Nhưng nhờ có bạn mà mình đã tìm được cách xử lý rồi ạ.

Bài đã được tự động gộp: Thứ sáu lúc 22:14

thanthanhan đã viết:
Bạn dùng thử xem thế nào.

Cảm ơn anh đã trợ giúp. Nhưng khi em chạy thử thì không ra được kết quả như em mong muốn ạ. Em đã tìm được cách xử lý vấn đề nhờ những gợi ý từ các anh ạ. Em cảm ơn rất nhiều ạ.

Hoàng Tuấn 868 · Thứ sáu lúc 23:04

NTNtran đã viết:
mình đã tìm được cách xử lý rồi ạ.

Nếu có thể thì chia sẻ cách sử lý đó lên để bạn nào có trường hợp tương tự cũng áp dụng được.

thanthanhan · Thứ bảy lúc 19:56

NTNtran đã viết:
Cảm ơn bạn đã giúp đỡ, nhưng đoạn mã không chạy được. Nhưng nhờ có bạn mà mình đã tìm được cách xử lý rồi ạ.
[tự động hợp nhất]1759504487[/tự động hợp nhất]

Cảm ơn anh đã giúp đỡ. Nhưng khi em thử thì không ra kết quả như em mong muốn ạ. Em đã tìm được cách xử lý vấn đề nhờ những lời khuyên từ các anh ạ. Em cảm ơn rất nhiều ạ.

Nếu vậy, bạn phải đưa ra kết quả mong muốn như thế nào để mọi người có thể hiểu được.

NTNtran · Thứ bảy lúc 21:55

Hoàng Tuấn 868 đã viết:
Nếu có thể thì chia sẻ cách sử lý đó lên để bạn nào có trường hợp tương tự cũng áp dụng được.

Đây là đoạn mã mình đã dùng để chạy. Nó tách xong và ghi vào sheet mới, giá trị sau khi tách sẽ được ghi vào cột thứ 9, đồng thời nội dung các ô còn lại của dòng gốc cũng được tự điền luôn. Hy vong sẽ giúp được cho bạn nào gặp trường hợp tương tự ạ.

Function PhanBoTien(SoTien As Double) As Variant
Const DonVi As Double = 500000000
Dim ketQua() As Double
Dim SoLan As Long, Du As Double, i As Long

If SoTien <= 0 Then
PhanBoTien = Array()
Exit Function
End If

SoLan = WorksheetFunction.RoundDown(SoTien / DonVi, 0)
Du = SoTien - (SoLan * DonVi)

ReDim ketQua(0 To SoLan - 1 + IIf(Du > 0, 1, 0))

For i = 0 To SoLan - 1
ketQua(i) = DonVi
Next i

If Du > 0 Then
ketQua(UBound(ketQua)) = Du
End If

PhanBoTien = ketQua
End Function

Sub TachBangTinh_SangSheetMoi()
Dim wsNguon As Worksheet, wsMoi As Worksheet
Dim i As Long, dongMoi As Long, lastRow As Long, lastCol As Long
Dim val As Double, ketQua As Variant
Dim originalRow As Range, j As Long

Set wsNguon = ActiveSheet
Set wsMoi = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wsMoi.Name = "DaTach_" & Format(Now, "hhmmss")

lastCol = wsNguon.Cells(5, wsNguon.Columns.Count).End(xlToLeft).Column
wsNguon.Range(wsNguon.Cells(5, 1), wsNguon.Cells(5, lastCol)).Copy
wsMoi.Range("A1").PasteSpecial xlPasteValues

lastRow = wsNguon.Cells(wsNguon.Rows.Count, "A").End(xlUp).Row
dongMoi = 2

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

For i = 6 To lastRow
If IsNumeric(wsNguon.Cells(i, 8).Value) Then
val = wsNguon.Cells(i, 8).Value
If val > 0 Then
ketQua = PhanBoTien(val)
Set originalRow = wsNguon.Range(wsNguon.Cells(i, 1), wsNguon.Cells(i, lastCol))

For j = LBound(ketQua) To UBound(ketQua)
originalRow.Copy
wsMoi.Range(wsMoi.Cells(dongMoi, 1), wsMoi.Cells(dongMoi, lastCol)).PasteSpecial xlPasteValues
wsMoi.Cells(dongMoi, 9).Value = ketQua(j) ' Ghi vÃ o cá»™t thá»© 9
dongMoi = dongMoi + 1
Next j
End If
End If
Next i

Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "ÄÃ£ tÃ¡ch xong vÃ ghi vÃ o sheet má»›i: " & wsMoi.Name, vbInformation
End Sub

Bài đã được tự động gộp: Thứ bảy lúc 22:00

thanthanhan đã viết:
Nếu vậy, bạn phải đưa ra kết quả mong muốn như thế nào để mọi người có thể hiểu được.

Vâng. Do em chưa đưa ra rõ kết quả mong muốn nên mọi người chưa hiểu để có thể giúp em 1 cách sát nhất. Cảm ơn lời góp ý của anh ạ. Lần sau em sẽ lưu ý hơn ạ.

HieuCD · Chủ nhật lúc 00:47

NTNtran đã viết:
Em có 1 bảng tính vài trăm người và cần xử lý như sau: nếu giá trị tại cột H (cột thứ 8), bắt đầu từ dòng số 5, lớn hơn 500,000,000, thì sẽ tự động tách thành nhiều dòng, mỗi dòng có giá trị 500,000,000, và nếu còn dư thì dòng cuối cùng sẽ chứa phần dư. Các cao nhân giúp em với ạ.

Dùng thử code sau . . .

Mã:

Sub abc()
  Dim sh As Worksheet, arr(), res()
  Dim sR&, i&, j&, k&, n&, T#
  Const C# = 500000000
 
  With Sheets("131 TK 6666")
    arr = .Range("A5", .Range("H" & Rows.Count).End(xlUp)).Value
  End With
  sR = UBound(arr)
 
KhaiBaoLaiTangSoDongKetQua:
  n = n + 10000 'Neu du lieu nhieu co the tang So 10000 len
  k = 0
  ReDim res(1 To n, 1 To 9) 'Tao mang ket qua
  For i = 1 To sR
    T = arr(i, 8)
    Do While T > 0
      k = k + 1
      If k > n Then GoTo KhaiBaoLaiTangSoDongKetQua
      For j = 1 To 8
        res(k, j) = arr(i, j)
      Next j
      If T > C Then res(k, 9) = C Else res(k, 9) = T
      T = T - res(k, 9)
    Loop
  Next i
  Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  sh.Name = "DaTach_" & Format(Now, "ddhhmmss")
  sh.Range("A5").Resize(k, 9) = res
  MsgBox "Da tach xong va ghi vao sheet: " & Chr(10) & Chr(10) & sh.Name, vbInformation
End Sub

Code đã chỉnh lại để xử lý dữ liệu khá lớn

NTNtran · Chủ nhật lúc 12:16

HieuCD đã viết:

Dùng thử code sau . . .

Mã:

Sub abc()
  Dim sh As Worksheet, arr(), res()
  Dim sR&, i&, j&, k&, n&
  Const C# = 500000000
 
  With Sheets("131 TK 6666")
    arr = .Range("A5", .Range("H" & Rows.Count).End(xlUp)).Value
  End With
  sR = UBound(arr)
 
KhaiBaoLaiTangSoDongKetQua:
  n = n + 10000 'Neu du lieu nhieu co the tang So 10000 len
  ReDim res(1 To n, 1 To 9) 'Tao mang ket qua
  For i = 1 To sR
    Do While arr(i, 8) > 0
      k = k + 1
      If k > n Then GoTo KhaiBaoLaiTangSoDongKetQua
      For j = 1 To 8
        res(k, j) = arr(i, j)
      Next j
      If arr(i, 8) > C Then res(k, 9) = C Else res(k, 9) = arr(i, 8)
      arr(i, 8) = arr(i, 8) - res(k, 9)
    Loop
  Next i
  Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  sh.Name = "DaTach_" & Format(Now, "ddhhmmss")
  sh.Range("A5").Resize(k, 9) = res
  MsgBox "Da tach xong va ghi vao sheet: " & Chr(10) & Chr(10) & sh.Name, vbInformation
End Sub

Em cảm ơn anh rất nhiều ạ. Đây thực sự là đoạn mã mà em cần (Dù em đã xử lý được vấn đề rồi).

thanthanhan · Hôm qua, lúc 09:00

NTNtran đã viết:
Em cảm ơn anh rất nhiều ạ. Đây thực sự là đoạn mã mà em cần (Dù em đã xử lý được vấn đề rồi).

Bạn chưa xử lý dòng cuối. Phần "tổng cộng" vẫn phân bổ.
Đoạn For i = 1 To sR bạn sửa lại thành For i = 1 To sR - 1 thì sẽ bỏ dòng tổng tiền (mà hình như tổng tiền trong sheet gốc của bạn bị tổng sai)
Code của bác HIEUCD thì quá hay và cao cấp rồi.

SA_DQ · Hôm qua, lúc 18:23

PHP:

Sub TaiPhanBo()
 Const FB As LongLong = 500000000
 Dim Rws As Long, DCK As LongLong, SoDu As LongLong, W As Long, SoDg As Integer, Col As Integer
 Dim Dg As Integer                          'DCK:= Du Cuôi Kì  '
 Dim Cls As Range
 
 Sheets("131TK").Select
 Rws = Sheets("131TK").UsedRange.Rows.Count
 SoFB = Cells(Rws + 9, "H").End(xlUp).Value / FB + Rws
 ReDim Arr(1 To SoFB, 1 To 4)
 For Each Cls In Range([A5], [A5].End(xlDown))
    W = W + 1:                          '    If W > 7 Then Exit For '
    DCK = Cells(Cls.Row, "H").Value:        SoDg = Int(DCK / FB)
    SoDu = DCK - SoDg * FB
    If SoDg < 1 Then
        Arr(W, 1) = Cls.Value:              Arr(W, 2) = Cls.Offset(, 1).Value
        Dg = Cls.Row:                       Arr(W, 3) = Cells(Dg, "F").Value
        Arr(W, 4) = DCK
    Else
        Arr(W, 1) = Cls.Value:              Arr(W, 2) = Cls.Offset(, 1).Value
        Dg = Cls.Row:                       Arr(W, 3) = Cells(Dg, "F").Value
        For hg = 1 To SoDg
            Arr(W, 4) = FB:                 W = W + 1
        Next hg
        If SoDu > 0 Then
            Arr(W, 4) = SoDu
        Else
            W = W - 1
        End If
    End If
 Next Cls
 [K5].Resize(W, 4).Value = Arr()
End Sub

NTNtran · Hôm qua, lúc 20:05

thanthanhan đã viết:
Bạn chưa xử lý dòng cuối. Phần "tổng cộng" vẫn phân bổ.
Đoạn For i = 1 To sR bạn sửa lại thành For i = 1 To sR - 1 thì sẽ bỏ dòng tổng tiền (mà hình như tổng tiền trong sheet gốc của bạn bị tổng sai)
Code của bác HIEUCD thì quá hay và cao cấp rồi.

Dạ. Em cảm ơn anh nhiều ạ. Em đã khắc phục theo hướng dẫn của anh ạ. Cảm ơn anh rất nhiều.

NTNtran · Hôm qua, lúc 22:32

SA_DQ đã viết:

PHP:

Sub TaiPhanBo()
 Const FB As LongLong = 500000000
 Dim Rws As Long, DCK As LongLong, SoDu As LongLong, W As Long, SoDg As Integer, Col As Integer
 Dim Dg As Integer                          'DCK:= Du Cuôi Kì  '
 Dim Cls As Range
 
 Sheets("131TK").Select
 Rws = Sheets("131TK").UsedRange.Rows.Count
 SoFB = Cells(Rws + 9, "H").End(xlUp).Value / FB + Rws
 ReDim Arr(1 To SoFB, 1 To 4)
 For Each Cls In Range([A5], [A5].End(xlDown))
    W = W + 1:                          '    If W > 7 Then Exit For '
    DCK = Cells(Cls.Row, "H").Value:        SoDg = Int(DCK / FB)
    SoDu = DCK - SoDg * FB
    If SoDg < 1 Then
        Arr(W, 1) = Cls.Value:              Arr(W, 2) = Cls.Offset(, 1).Value
        Dg = Cls.Row:                       Arr(W, 3) = Cells(Dg, "F").Value
        Arr(W, 4) = DCK
    Else
        Arr(W, 1) = Cls.Value:              Arr(W, 2) = Cls.Offset(, 1).Value
        Dg = Cls.Row:                       Arr(W, 3) = Cells(Dg, "F").Value
        For hg = 1 To SoDg
            Arr(W, 4) = FB:                 W = W + 1
        Next hg
        If SoDu > 0 Then
            Arr(W, 4) = SoDu
        Else
            W = W - 1
        End If
    End If
 Next Cls
 [K5].Resize(W, 4).Value = Arr()
End Sub

Dạ. Em cảm ơn anh nhiều ạ. Nhưng code em chạy bị lỗi, không chạy được anh ơi.

Hoàng Tuấn 868 · Hôm qua, lúc 22:34

NTNtran đã viết:
Dạ. Em cảm ơn anh nhiều ạ. Nhưng code em chạy bị lỗi, không chạy được anh ơi.

Lỗi như thế nào bạn nên nói rõ thì tác giả mới biết để điều chỉnh cho bạn chứ.

Viết macro tự động tách giá trị theo điều kiện và chèn thêm dòng (1 người xem)

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

NTNtran

Thành viên mới

File đính kèm

thanthanhan

Thành viên chính thức

File đính kèm

SA_DQ

/(hông là gì!

NTNtran

Thành viên mới

Hoàng Tuấn 868

Đăng ký hôm qua

thanthanhan

Thành viên chính thức

NTNtran

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

NTNtran

Thành viên mới

thanthanhan

Thành viên chính thức

SA_DQ

/(hông là gì!

NTNtran

Thành viên mới

NTNtran

Thành viên mới

Hoàng Tuấn 868

Đăng ký hôm qua

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

Thời gian đếm ngược.