+ Reply to Thread
Results 1 to 18 of 18

copy cells from sheets based on date, paste to another sheet

Hybrid View

  1. #1
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    copy cells from sheets based on date, paste to another sheet

    I am getting myself in a knot here.
    On sheet "CoA" i have at table of periodic payments that is created via an input form and what I want to do is have accounting entries automatically generated in my cask book based on dates.

    The code for the input form is as follows;
    Private Sub CmdBtnClear_Click()
        Call Userform_Initialize
    End Sub
    
    Private Sub CmdBtnCancel_Click()
        Unload Me
    End Sub
    
    Private Sub CmdBtnOK_Click()
    
    Dim Today
    Today = Now
    
    If Me.tbxTo.Value = "" Then
            MsgBox "Please enter Customer / Supplier name.", vbExclamation, "Cash / Bank Transactions - Who?!"
            Me.tbxAmount.SetFocus
            Exit Sub
        End If
    If Me.tbxDesc.Value = "" Then
            MsgBox "Please enter a short description.", vbExclamation, "Cash / Bank Transactions - What?"
            Me.tbxDesc.SetFocus
            Exit Sub
        End If
    If Me.tbxDate.Value = "" Then
            MsgBox "Please enter a Date.", vbExclamation, "When does the standing order start."
            Me.tbxDate.SetFocus
            Exit Sub
        End If
    If Me.tbxAmount.Value = "" Then
            MsgBox "Please enter an Amount.", vbExclamation, "Cash / Bank Transactions - O what a dill!"
            Me.tbxAmount.SetFocus
            Exit Sub
        End If
    If Me.cbxFreq.Value = "" Then
            MsgBox "Enter the frequency of payments.", vbExclamation, "Cash / Bank Transactions - oops"
            Me.cbxAccount.SetFocus
            Exit Sub
        End If
    If Me.cbxAccount.Value = "" Then
            MsgBox "Please select an Account from the drop down list or insert the account number.", vbExclamation, "Cash / Bank Transactions - oops"
            Me.cbxAccount.SetFocus
            Exit Sub
        End If
    
    ActiveWorkbook.Sheets("CoA").Activate
    Range("i47").Select
    
        Do
            If IsEmpty(ActiveCell) = False Then
                ActiveCell.Offset(1, 0).Select
            End If
    
        Loop Until IsEmpty(ActiveCell) = True
        
        ActiveCell.Value = tbxDate.Value
        ActiveCell.Offset(0, 1) = cbxFreq.Value
        ActiveCell.Offset(0, 2) = tbxTo.Value
        ActiveCell.Offset(0, 3) = tbxDesc.Value
        ActiveCell.Offset(0, 4) = tbxRef.Value
        ActiveCell.Offset(0, 5) = cbxAccount.Value
        ActiveCell.Offset(0, 6) = tbxAmount.Value
    
    
    If tbxDate.Value < Today Then
    
    ActiveCell.Offset(0, 7) = tbxDate.Value ' to record on CoA first entry (below)
    
    ActiveWorkbook.Sheets("Receipts & Payments").Activate
    Range("a10").Select
    
        Do
            If IsEmpty(ActiveCell) = False Then
                ActiveCell.Offset(1, 0).Select
            End If
    
        Loop Until IsEmpty(ActiveCell) = True
        
        ActiveCell.Value = tbxDate.Value
        ActiveCell.Offset(0, 1) = tbxTo.Value
        ActiveCell.Offset(0, 2) = tbxDesc.Value
        ActiveCell.Offset(0, 3) = cbxAccount.Value
        ActiveCell.Offset(0, 4) = tbxRef.Value
        ActiveCell.Offset(0, 10) = tbxAmount.Value
    End If
    
    End Sub
    
    Private Sub Userform_Initialize()
    
        Dim rList  As Range
    
        '//Define the list and where it's obtained from (Columns A, & B in this example)
        With Worksheets("CoA")
            Set rList = .Range(.Cells(15, 1), .Cells(.Rows.Count, 2).End(xlUp))
    
        End With
    
        With Me
            
            With cbxAccount
                .ColumnCount = 2
                .ColumnWidths = 25
                .Width = 220
                .Height = 20
                .List = rList.Value
                .ListRows = 25
            End With
            
            With cbxFreq
                .AddItem "1"
                .AddItem "2"
                .AddItem "3"
                .AddItem "4"
                .AddItem "5"
                .AddItem "6"
                .AddItem "7"
                .AddItem "8"
                .AddItem "9"
                .AddItem "10"
                .AddItem "11"
                .AddItem "12"
                .ListRows = 12
            End With
        
                ' sets the other fields to zero
        
    '    tbxDate.Value = ""
        cbxFreq.Value = ""
        tbxTo.Value = ""
        tbxDesc.Value = ""
        tbxRef.Value = ""
        cbxAccount.Value = ""
        tbxAmount.Value = ""
        tbxTo.SetFocus
    
    
    
    End With
    
    End Sub
    The table entries work fine but the entries on sheet "Receipts & Payments" don't get made. It seems I am not using the date logic properly.

    Then I have problems getting the change event / date based entries to work.

    I think the logic is evident from the code and notes;

    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    
        Sheets("CoA").Select
        Range("I47").Select
    
        Do While ActiveCell <> ""
            
            If ActiveCell.Value < Now Then ' checks to see if contract date is before the present date - if yes go to next evaluation
            
                If ActiveCell.Offset(0, 7).Value = "" Then ' if there is no previous accounting entry date then
                    
                    If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Now Then ' if contract start plus one frequency period is before present date
                         Call enterdata                   ' create entries on Receipts & Payments
                                        
                    End If
                    
                Else
                    If ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value) < Now Then    ' if last entry plus one frequency period is before present date
        
                         Call enterdata                   ' create entries on Receipts & Payments
                    End If
                End If
            End If
        
        ActiveCell.Offset(1, 0).Select 'evaluate next row
            
        Loop ' Until IsEmpty(ActiveCell) = True
        
        Exit Sub
    
    End Sub
    
    Private Sub enterdata()
    
    ActiveWorkbook.Sheets("Receipts & Payments").Activate
    Range("a10").Select
    
        Do
        If IsEmpty(ActiveCell) = False Then
        ActiveCell.Offset(1, 0).Select
        End If
    
        Loop Until IsEmpty(ActiveCell) = True
    
        ActiveCell.Value = Sheets("CoA").ActiveCell.Value
        ActiveCell.Offset(0, 1) = Sheets("CoA").ActiveCell.Offset(2, 0).Value
        ActiveCell.Offset(0, 2) = Sheets("CoA").ActiveCell.Offset(3, 0).Value
        ActiveCell.Offset(0, 3) = Sheets("CoA").ActiveCellOffset(5, 0).Value
        ActiveCell.Offset(0, 4) = Sheets("CoA").ActiveCell.Offset(4, 0).Value
        ActiveCell.Offset(0, 10) = Sheets("CoA").ActiveCell.Offset(6, 0).Value
        
        ActiveWorkbook.Sheets("Coa").Activate
     
            If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Now Then
                    ActiveCell.Offset(0, 7).Value = ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value)
                    ' if contract start plus one frequency period is before present date
            Else: ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value)
                                        
            End If
                    
    
    
    End Sub
    Can anyone see where I am going wrong? Please?
    Attached Images Attached Images

  2. #2
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    I am not sure if this will solve your problems, but I would assign Today = Date, not Now. Date is an integer for today, Now is a decimal. The way your code is written I believe Today would always be > txbDate.value, unless that value is tomorrow or later. Also, if txbDate is a text box, you may want to go CDate(txbDate.value) to turn the string into a date value.

    Does that help?
    Is your code running too slowly?
    Does your workbook or database have a bunch of duplicate pieces of data?
    Have a look at this article to learn the best ways to set up your projects.
    It will save both time and effort in the long run!


    Dave

  3. #3
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    Thanks for your help. It is getting a bit late here and my wife has just arrived home so attention is needed elsewhere. I will try your suggestions tomorrow.

  4. #4
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    Quote Originally Posted by davegugg View Post
    ...Today would always be > txbDate.value, unless that value is tomorrow or later. ...
    Although true for most cases it is possible for the user to set up the schedule for future commitments.

  5. #5
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    Quote Originally Posted by upod View Post
    Although true for most cases it is possible for the user to set up the schedule for future commitments.

    I just want to be sure you understand what happens when the current date is put into cbxDate.

  6. #6
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    Well I am not sure the suggestions are helping (tbxDate, not txbDate) but I am getting a 1004 error "method select of object range failed" pointing at Range("I47").Select, the fifth line of code on the worksheet change

    At the risk of repeating myself there are 2 distinct events; the first when the user sets up a schedule of future payment commitments, and the second based on a worksheet change. Because the first event makes an entry on the Receipts and Payments worksheet it triggers the second event, where it seems the problem lies.

    After making the changes suggested by davegugg i have the following for the input form entries (have removed the error messages for empty textboxes and initialize ;
    Private Sub CmdBtnOK_Click()
    
    Dim Today
    Today = Date
    
    
    
    ActiveWorkbook.Sheets("CoA").Activate
    Range("i47").Select
    
        Do
            If IsEmpty(ActiveCell) = False Then
                ActiveCell.Offset(1, 0).Select
            End If
    
        Loop Until IsEmpty(ActiveCell) = True
        
        ActiveCell.Value = tbxDate.Value
        ActiveCell.Offset(0, 1) = cbxFreq.Value
        ActiveCell.Offset(0, 2) = tbxTo.Value
        ActiveCell.Offset(0, 3) = tbxDesc.Value
        ActiveCell.Offset(0, 4) = tbxRef.Value
        ActiveCell.Offset(0, 5) = cbxAccount.Value
        ActiveCell.Offset(0, 6) = tbxAmount.Value
    
    
    If CDate(tbxDate.Value) < Today Then
    
    ActiveCell.Offset(0, 7) = tbxDate.Value ' to record on CoA first entry (below)
    
    ActiveWorkbook.Sheets("Receipts & Payments").Activate
    Range("a10").Select
    
        Do
            If IsEmpty(ActiveCell) = False Then
                ActiveCell.Offset(1, 0).Select
            End If
    
        Loop Until IsEmpty(ActiveCell) = True
        
        ActiveCell.Value = tbxDate.Value
        ActiveCell.Offset(0, 1) = tbxTo.Value
        ActiveCell.Offset(0, 2) = tbxDesc.Value
        ActiveCell.Offset(0, 3) = cbxAccount.Value
        ActiveCell.Offset(0, 4) = tbxRef.Value
        ActiveCell.Offset(0, 10) = tbxAmount.Value
    End If
    
    End Sub
    and this is the revised code for the Receipts & Payments (sheet 9) change event
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        
    Dim Today
    Today = Date
        
        Sheets("CoA").Select
        Range("I47").Select
    
        Do While ActiveCell.Value <> ""
            
            If ActiveCell.Value < Today Then ' checks to see if contract date is before the present date - if yes go to next evaluation
            
                If ActiveCell.Offset(0, 7).Value = "" Then ' if there is no previous accounting entry date then
                    
                    If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then ' if contract start plus one frequency period is before present date
                         Call enterdata                   ' create entries on Receipts & Payments
                                        
                    End If
                    
                Else
                    If ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then    ' if last entry plus one frequency period is before present date
        
                         Call enterdata                   ' create entries on Receipts & Payments
                    End If
                End If
            End If
        
        ActiveCell.Offset(1, 0).Select 'evaluate next row
            
        Loop ' Until IsEmpty(ActiveCell) = True
        
        Exit Sub
    
    End Sub
    
    Private Sub enterdata()
    
    ActiveWorkbook.Sheets("Receipts & Payments").Activate
    Range("a10").Select
    
        Do
        If IsEmpty(ActiveCell) = False Then
        ActiveCell.Offset(1, 0).Select
        End If
    
        Loop Until IsEmpty(ActiveCell) = True
    
        ActiveCell.Value = Sheets("CoA").ActiveCell.Value
        ActiveCell.Offset(0, 1) = Sheets("CoA").ActiveCell.Offset(2, 0).Value
        ActiveCell.Offset(0, 2) = Sheets("CoA").ActiveCell.Offset(3, 0).Value
        ActiveCell.Offset(0, 3) = Sheets("CoA").ActiveCellOffset(5, 0).Value
        ActiveCell.Offset(0, 4) = Sheets("CoA").ActiveCell.Offset(4, 0).Value
        ActiveCell.Offset(0, 10) = Sheets("CoA").ActiveCell.Offset(6, 0).Value
        
        ActiveWorkbook.Sheets("CoA").Activate
     
            If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then
                    ActiveCell.Offset(0, 7).Value = ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value)
                    ' if contract start plus one frequency period is before present date
            Else: ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value)
                                        
            End If
                    
    
    
    End Sub
    Have I adequately explained the problem? I would appreciate any help on this.

  7. #7
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    Do you have the code in a module? That is where it should be.

  8. #8
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    I have now created a separate module which is called from the worksheet change event. This appears to run further but now gets stuck where I am copying data. Annotated below.
     Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        
    Call CheckPaySchSO
    
    End Sub
    ------
    Sub CheckPaySchSO()
    
    Dim Today
    Today = Date
        
        Sheets("CoA").Select
        Range("I47").Select
    
        Do While ActiveCell.Value <> ""
            
            If ActiveCell.Value < Today Then ' checks to see if contract date is before the present date - if yes go to next evaluation
            
                If ActiveCell.Offset(0, 7).Value = "" Then ' if there is no previous accounting entry date then
                    
                    If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then ' if contract start plus one frequency period is before present date
                         Call enterdata                   ' create entries on Receipts & Payments
                                        
                    End If
                    
                Else
                    If ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then    ' if last entry plus one frequency period is before present date
        
                         Call enterdata                   ' create entries on Receipts & Payments
                    End If
                End If
            End If
        
        ActiveCell.Offset(1, 0).Select 'evaluate next row
            
        Loop ' Until IsEmpty(ActiveCell) = True
        
        Exit Sub
    
    End Sub
    
    Private Sub enterdata()
    
    ActiveWorkbook.Sheets("Receipts & Payments").Activate
    Range("a10").Select
    
        Do
        If IsEmpty(ActiveCell) = False Then
        ActiveCell.Offset(1, 0).Select
        End If
    
        Loop Until IsEmpty(ActiveCell) = True
    
        ActiveCell.Value = Sheets("CoA").ActiveCell.Value  'Gets stuck here
        ActiveCell.Offset(0, 1) = Sheets("CoA").ActiveCell.Offset(2, 0).Value
        ActiveCell.Offset(0, 2) = Sheets("CoA").ActiveCell.Offset(3, 0).Value
        ActiveCell.Offset(0, 3) = Sheets("CoA").ActiveCellOffset(5, 0).Value
        ActiveCell.Offset(0, 4) = Sheets("CoA").ActiveCell.Offset(4, 0).Value
        ActiveCell.Offset(0, 10) = Sheets("CoA").ActiveCell.Offset(6, 0).Value
        
        ActiveWorkbook.Sheets("CoA").Activate
     
            If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then
                    ActiveCell.Offset(0, 7).Value = ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value)
                    ' if contract start plus one frequency period is before present date
            Else: ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value)
                                        
            End If
                    
    End Sub

    Presumably this is not the correct way to copy the cells of the rows that meet the if criteria. So how do I do this?
    Last edited by upod; 10-22-2009 at 12:56 PM. Reason: Makes easier reading to see all the code instead of one line

  9. #9
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    Right, the problem is you have activecell on both sides of the equal sign. The ActiveCell property only identifies the active cell on the active sheet. So if CoA is not the active sheet, Sheets("CoA").ActiveCell doesn't make any sense.
    Can you use the cell index instead? For example:

    ActiveCell.Value = Sheets("CoA").Cells(1,1).Value ' But your cell instead of 1,1.

  10. #10
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    I can't use a fixed reference because the module that precedes is looping down the list checking date criteria. When it finds a row that meet the criteria some of the data is put in the second sheet, and so on.

  11. #11
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    Then you need to assign a variable to stand for that cell you are trying to copy. Its hard to tell where because your code is too spaced out but:
    I think right here you'd go

    If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then ' if contract start plus one frequency period is before present date
        CellAddress = ActiveCell.Address
        Call enterdata                   ' create entries on Receipts & Payments
    You need to dim CellAddress as a String.

    Then when you get to the line that was causing you trouble, you should be able to go


    ActiveCell.Value = Sheets("CoA").Range(CellAddress).Value

  12. #12
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    I did as you suggested and I am still getting a run-time error '1004', 'Application-defined or object-defined error' on the line
     ActiveCell.Value = Sheets("CoA").Range(CellAddress).Value
    Although the code fails at this point the actual date does get pasted to the second sheet: but that is as far as it goes. Any other ideas?

  13. #13
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    I can't see how the date would get pasted but the code would still fail on that line. Did you alter the lines directly after that line? I noticed they also have the activecell property on both sides of the equal sign.

  14. #14
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    Yes, I changed them as follows;
        ActiveCell.Value = Sheets("CoA").Range(CellAddress).Value
        ActiveCell.Offset(0, 1) = Sheets("CoA").Range(CellAddress).Offset(0, 2).Value
        ActiveCell.Offset(0, 2) = Sheets("CoA").Range(CellAddress).Offset(0, 3).Value
        ActiveCell.Offset(0, 3) = Sheets("CoA").Range(CellAddress)(0, 5).Value
        ActiveCell.Offset(0, 4) = Sheets("CoA").Range(CellAddress).Offset(0, 4).Value
        ActiveCell.Offset(0, 10) = Sheets("CoA").Range(CellAddress).Offset(0, 6).Value
    Thanks for taking the time to look at this by the way.

  15. #15
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    Hmm, I can't think of a reason that it would fail. After you get the error, what does it say CellAddress is equal to when you hold the cursor over it while debugging?

    Otherwise if you could post the workbook, that'd make it easier to troubleshoot.

  16. #16
    Registered User
    Join Date
    06-09-2008
    Posts
    28

    Re: copy cells from sheets based on date, paste to another sheet

    Ok here is a chopped down version of the workbook.

    I have changed the sheet event to 'calculate' and the first part now seems to work when payments are set up but when it comes to the the sheet 9 update, the code it gets stuck.
    Attached Files Attached Files

  17. #17
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    Ok, I see what the problem is. Give me a bit to fix it, I'm pretty busy with my real job today.

  18. #18
    Forum Expert davegugg's Avatar
    Join Date
    12-18-2008
    Location
    WI, US
    MS-Off Ver
    2010
    Posts
    1,884

    Re: copy cells from sheets based on date, paste to another sheet

    Ok, I rewrote your code. Here are a couple of issues:
    1) You don't need to select things. Look closely at how I reworked all the "Select" code to make it more efficient. It will run much faster this way.
    2) Your Frequency select between months cells don't work. The Month() function tells you what month the date you put in is in. For example, Month(Date) = 10 (October is the tenth month). Dates are stored as integers in excel. Since you put 1 and 3 in those cells, you are actually looking at 1/1/1900 and 1/3/1900. If you want to add a month, put 30 in those cells and just add the cell value instead of using the month code.
    3) The reason it was giving you this last error was the scope of the variable was local. To make it work, above both modules define it as public. For example: Public yourvariable as String.

    Go through this code and see the changes carefully. I put the revised code near the commented out lines of your code so you could see how they correspond. Then after, go ahead and delete out your code. If it is then not working properly, let me know and we'll tweak some more.

    Sub CheckPaySchSO()
    '
    ' Macro recorded 20/10/2009 by Philip Sharp
    Dim intLSORow As Integer 'Last cell in Standing Orders table
    Dim CellAddress As String
    Dim Today As Date
    Dim a As Integer
    
    Today = Date
    intLSORow = Sheets("CoA").Cells(47, "I").End(xlDown).Row
        
    Sheets("CoA").Activate
    
    'Do While ActiveCell.Value <> ""
    For a = 47 To intLSORow
        If Sheets("CoA").Cells(a, "I").Value < Today Then
        'If ActiveCell.Value < Today Then ' checks to see if contract date is before the present date - if yes go to next evaluation
            If Sheets("CoA").Cells(a, "P").Value = "" Then
            'If ActiveCell.Offset(0, 7).Value = "" Then ' if there is no previous accounting entry date then
                If Cells(a, "I").Value + Sheets("CoA").Cells(a, "J").Value < Today Then
                'If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then ' if contract start plus one frequency period is before present date
                     'CellAddress = Sheets("CoA").Cells(a, "I").Address
                     Call enterdata(a)                   ' create entries on Receipts & Payments
                End If
            Else
                'If ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then    ' if last entry plus one frequency period is before present date
                If Sheets("CoA").Cells(a, "P").Value + Sheets("CoA").Cells(a, "J").Value < Today Then
                     'CellAddress = ActiveCell.Address
                     Call enterdata(a)                   ' create entries on Receipts & Payments
                End If
            End If
        End If
    Next a
    
    End Sub
    
    Private Sub enterdata(intRowNum As Integer)
    
    Dim CellAddress As String
    Dim Today As Date
    Dim intNRPRow As Integer 'Next row in Receipts and Payments Table.
    
    Today = Date
    intNRPRow = Sheets("Receipts & Payments").Cells(10, "A").End(xlDown).Row + 1
    
    With Sheets("Receipts & Payments")
        .Cells(intNRPRow, 1).Value = Sheets("CoA").Cells(intRowNum, "I").Value
        .Cells(intNRPRow, 2).Value = Sheets("CoA").Cells(intRowNum, "K").Value
        .Cells(intNRPRow, 3).Value = Sheets("CoA").Cells(intRowNum, "L").Value
        .Cells(intNRPRow, 4).Value = Sheets("CoA").Cells(intRowNum, "N").Value
        .Cells(intNRPRow, 5).Value = Sheets("CoA").Cells(intRowNum, "M").Value
        .Cells(intNRPRow, 11).Value = Sheets("CoA").Cells(intRowNum, "O").Value
    End With
    
    
    'ActiveWorkbook.Sheets("Receipts & Payments").Activate
    'Range("a10").Select
    '
    '    Do
    '    If IsEmpty(ActiveCell) = False Then
    '    ActiveCell.Offset(1, 0).Select
    '    End If
    '
    '    Loop Until IsEmpty(ActiveCell) = True
    '
    '    ActiveCell.Value = Sheets("CoA").Range(CellAddress).Value
    '    ActiveCell.Offset(0, 1) = Sheets("CoA").Range(CellAddress).Offset(0, 2).Value
    '    ActiveCell.Offset(0, 2) = Sheets("CoA").Range(CellAddress).Offset(0, 3).Value
    '    ActiveCell.Offset(0, 3) = Sheets("CoA").Range(CellAddress)(0, 5).Value
    '    ActiveCell.Offset(0, 4) = Sheets("CoA").Range(CellAddress).Offset(0, 4).Value
    '    ActiveCell.Offset(0, 10) = Sheets("CoA").Range(CellAddress).Offset(0, 6).Value
    '
    '    ActiveWorkbook.Sheets("CoA").Activate
    '    Range("I47").Select
     
    'If ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value) < Today Then
    If Sheets("CoA").Cells(intRowNum, "I").Value + Sheets("CoA").Cells(intRowNum, "J").Value < Today Then
            'ActiveCell.Offset(0, 7).Value = ActiveCell.Value + Month(ActiveCell.Offset(0, 1).Value)
             Sheets("CoA").Cells(intRowNum, "P").Value = Sheets("CoA").Cells(intRowNum, "I").Value + Sheets("CoA").Cells(intRowNum, "J").Value
            ' if contract start plus one frequency period is before present date
    'Else: ActiveCell.Offset(0, 7).Value = ActiveCell.Offset(0, 7).Value + Month(ActiveCell.Offset(0, 1).Value)
    Else: Sheets("CoA").Cells(intRowNum, "P").Value = Sheets("CoA").Cells(intRowNum, "P") + Sheets("CoA").Cells(intRowNum, "J").Value
                                
    End If
                    
    End Sub

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1