宏或VBA代码可自动更新每日每周和每月报告的数据

Question

I have excel sheet with 9 columns and name are:

1. SNO
2. PO Number
3. Created Date
4. Currency
5. PO Amount
6. Global Funds Transfer Count
7. BankName
8. Status
9. Prepared User

I want to write a macro or VBA code which can help me save daily weekly and monthly report.

On sheet1 I will be pasting data for 150 rows for above 9 columns on daily basis and I want out of that to save 5 columns:

1.SNO 2.Bank name 3.po amount 4.Global Funds Transfer Count 5.prepared users to save automatically to sheet2.

Whenever I paste any data in sheet1 I want data of above 5 columns to be saved in sheet2 on date wise for each day. And from sheet2 I want my full data of sheet2 to sheet3 to take monthly report for above 5 column.

But when I update data old data from sheet2 get delete.

Sub sbCopyRangeToAnotherSheet()

    Sheets("Sheet1").Range("B1:B100").Copy _
      Destination:=Sheets("Sheet2").Range("A1")
    Sheets("Sheet1").Range("H1:H100").Copy _
      Destination:=Sheets("Sheet2").Range("B1") 
    Sheets("Sheet1").Range("G1:G100").Copy _
      Destination:=Sheets("Sheet2").Range("C1") 
    Sheets("Sheet1").Range("F1:F100").Copy _
      Destination:=Sheets("Sheet2").Range("D1") End Sub 

    Dim rng As Range

    'Store blank cells inside a variable
      On Error GoTo NoBlanksFound
        Set rng = Range("E1:E130").SpecialCells(xlCellTypeBlanks)
      On Error GoTo 0

    'Delete blank cells and shift upward
      rng.Rows.Delete Shift:=xlShiftUp

    Exit Sub

    'ERROR HANLDER
    NoBlanksFound:
      MsgBox "No Blank cells were found"

End Sub

Answer 1

If you want it fully automated, a 'best guess' at a trigger can be made but it is by no means fool-proof.

My 'best guess' is based on your statement of 'pasting data for 150 rows for above 9 columns'

I've avoided your msgbox error control since a truly automated process doesn't require one if error control has been provided.

In lieu of confirmation, I've assumed that Range("E1:E130") belongs to Sheet1.

Put this in the Sheet1 private code sheet (right-click worksheet name tab then View Code).

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("A:I")) Is Nothing Then
        If Intersect(Target, Range("A:I")).Count >= 1350 Then
            On Error GoTo safe_exit
            Application.EnableEvents = False

            Range("B1:B100").Copy Destination:=Worksheets("Sheet2").Range("A1")
            Range("H1:H100").Copy Destination:=Worksheets("Sheet2").Range("B1")
            Range("G1:G100").Copy Destination:=Worksheets("Sheet2").Range("C1")
            Range("F1:F100").Copy Destination:=Worksheets("Sheet2").Range("D1")

            If Application.CountA(Range("E1:E130")) < 130 Then _
                Range("E1:E130").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp

        End If
    End If

safe_exit:
    Application.EnableEvents = True
End Sub