Copy có điều kiện Số tiền > 0 bằng VBA. (1 người xem)

[mrloe]

Kính gửi các Anh/Chị.

Ở bài trước (Copy có Điều kiện dữ liệu từ sheet ngày sang sheet khác bằng VBA) em đã nhận được sự trợ giúp rất nhiệt từ Anh/Chị, đặc biệt là Anh (Chị) Kẻ_Độc_Hành, và em đã làm rất tốt theo lời gợi ý đó.

Giờ đây em đã tính ra Số tiền lương thực lĩnh của mỗi CBCNV ở trong sheet Total, nhưng bên Phòng Kế toán cty em chỉ làm thủ tục hạch toán cho những ai số tiền > 0.

Từ lẽ đó: Em cần thêm sự trợ giúp từ Anh/Chị việc copy những CBCNV nào có số tiền thực lĩnh > 0 từ sheet Total sang sheet Payment bằng VBA.

Lý do cần VBA: Vì bên em có gần 5.000 CBCNV nên việc lọc (Auto Fill) để copy/xoá đi thì hơi bị mệt ah.

Em cảm ơn Anh/Chị rất nhiều!

 

[bunbun85]

Code này xem có được không :

Sub Copydulieu()
Dim i As Long, k As Long, j As Long
Dim mNguon(), mDich()
mNguon = Sheets("Total").Range("A2:F26").Value
ReDim mDich(1 To UBound(mNguon), 1 To 6)
    For i = 1 To UBound(mNguon)
        If mNguon(i, 6) > 0 Then
            k = k + 1
            mDich(k, 1) = k
                For j = 2 To 6
                    mDich(k, j) = mNguon(i, j)
                Next
        End If
    Next i
If k Then Sheets("Payment").Range("A2").Resize(k, 6) = mDich

End Sub

 

[mrloe]

Dạ chạy rất tốt ah.

Cảm ơn anh rất nhiều!

 

[mrloe]

Theo đoạn code anh bunbun85 cho thì em đã copy được theo một vùng liền nhau từ A đến B. Ví dụ: Từ A2 đến F26.

Giờ em chỉ muốn copy một vài cột thôi thì em sửa code ở đoạn nào ah.

Ý em là: Em chỉ muốn copy cột B, C và F thôi ah, các cột khác em không copy.

Em xin cảm ơn rất nhiều ah.

 

[Quang_Hải]

Thêm 1 cách cho bạn tham khảo
Copy dòng tiêu đề từ sheet Total dán sang dòng 1 của sheet payment
Rồi copy đoạn code này vào sheet Payment. Khuyến mãi thêm dòng tổng cộng

Private Sub Worksheet_Activate()
[H1] = [F1].Value: [H2] = ">0"
Sheet1.[A1:F10000].AdvancedFilter 2, [H1:H2], [A1:F1]
[H1:H2] = ""
With [F65536].End(3)
   .FormulaR1C1 = "=Sum(R2C6:R" & .Row - 1 & "C6)"
End With
End Sub

 

[bunbun85]

Sub Copydulieu()
Dim i As Long, k As Long, j As Long
Dim mNguon(), mDich()
mNguon = Sheets("Total").Range("A2:F26").Value
ReDim mDich(1 To UBound(mNguon), 1 To 3)
    For i = 1 To UBound(mNguon)
        If mNguon(i, 6) > 0 Then
            k = k + 1
            mDich(k, 1) = mNguon(i, 2)
            mDich(k, 2) = mNguon(i, 3)
            mDich(k, 3) = mNguon(i, 6)
        End If
    Next i
If k Then Sheets("Payment").Range("A2").Resize(k, 3) = mDich
End Sub

 

[mrloe]

Anh giỏi thiệt, em cảm ơn nhiều ah!

 

[mrloe]

Thêm 1 cách cho bạn tham khảo
Copy dòng tiêu đề từ sheet Total dán sang dòng 1 của sheet payment
Rồi copy đoạn code này vào sheet Payment. Khuyến mãi thêm dòng tổng cộng

Private Sub Worksheet_Activate()
[H1] = [F1].Value: [H2] = ">0"
Sheet1.[A1:F10000].AdvancedFilter 2, [H1:H2], [A1:F1]
[H1:H2] = ""
With [F65536].End(3)
   .FormulaR1C1 = "=Sum(R2C6:R" & .Row - 1 & "C6)"
End With
End Sub

Đoạn code của anh quanghai1969 cũng rất hay. Em thêm một đoạn code mới nữa rồi.

Cảm ơn anh rất nhiều ah!

 

[bunbun85]

Thích có Tổng thì chạy code này :

Sub Copydulieu()
Dim i As Long, k As Long, j As Long, Total As Long
Dim mNguon(), mDich()
mNguon = Sheets("Total").Range("A2:F26").Value
ReDim mDich(1 To UBound(mNguon), 1 To 3)
Total = 0
    For i = 1 To UBound(mNguon)
        If mNguon(i, 6) > 0 Then
            k = k + 1
            mDich(k, 1) = mNguon(i, 2)
            mDich(k, 2) = mNguon(i, 3)
            mDich(k, 3) = mNguon(i, 6)
            Total = Total + mNguon(i, 6)
        End If
    Next i
If k Then Sheets("Payment").Range("A2").Resize(k, 3) = mDich
With Sheets("Payment").Range("A65536").End(3)
    .Offset(1).Value = Sheets("Total").Range("A27").Value 'Tan dung luon A27 dang chua chu TONG
    .Offset(1, 2).Value = Total
End With
End Sub

 

[Quang_Hải]

Chức năng mạnh của AdvancedFilter là lọc chọn cột. Bạn chỉ cần copy 3 cái tiêu đề bạn muốn lấy dữ liệu vào A1, B1, C1 rồi thử code này.
Ngắn gọn có thể chỉnh sửa dễ dàng

Private Sub Worksheet_Activate()
[F1] = [C1]: [F2] = ">0"
Sheet1.[A1:F10000].AdvancedFilter 2, [F1:F2], [A1:C1]
[F1:F2]=""
End Sub