Macro or vba code to automatically update data for daily weekly and monthly report

1
votes

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
1
vbaexcelexcel-2010
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 – june
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 – june
Please note that there is an edit button to edit your original question and add your code there and then remove the comments. Code in comments is unreadable. You might also want to format your question properly. It's more likely to get an answer if you show a clear and readable question. – Pᴇʜ
i tried to add code in questions but it ask to remove 4 space and i dont know how to do it. – june
Paste the code into the question. Highlight just the code and press Ctrl + K – QHarr

1 Answers

0
votes

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