Macro help

[CALLISTAJM]

Hi Guys,

I'm looking for a macro that if the 'PMT Day' is Monday and the invoice date is today or earlier - will put that line onto another sheet with the tab name (Clients name).

[TABLE="width: 1085"]
<colgroup><col><col><col span="2"><col><col><col span="2"><col><col></colgroup><tbody>[TR]
[TD] Vehicle Reg [/TD]
[TD] Amount £ [/TD]
[TD] Invoice Date [/TD]
[TD] PMT Date [/TD]
[TD]Amount PAID[/TD]
[TD]Balance remaining[/TD]
[TD] Days outstanding [/TD]
[TD] Overdue [/TD]
[TD]PMT TYPE[/TD]
[TD] PMT Day [/TD]
[/TR]
[TR]
[TD]AB12CDF[/TD]
[TD] £ 1.00
[/TD]
[TD]15/03/2018
[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]£1.00[/TD]
[TD] 42[/TD]
[TD] yes [/TD]
[TD]Blank[/TD]
[TD] Monday [/TD]
[/TR]
</tbody>[/TABLE]


I don't know how to edit macros but I did get a simular one off here before that I used, and I have tried to edit it with zero luck So any help will be greatly appreciated

Thanks in Advance,
Rose x

 

[louisH]

Hi,

Are you wishing to do this task on every row of your sheet ?
By "put that line" do you mean copying or cuting ?

Anyways here's a beginning :

Assuming PMT date is column D :

Dim lastRow as Long
lastRow = Range("D2").End(xlDown).Row

For Each c In Range("D2:D" & lastRow)

If WorksheetFunction.WeekNum(c.Value, 2) = 1 And Cells(c.Row, 3).Value <= Date Then

'Copy

End If

Next c

 

[CALLISTAJM]

Yes for every line on the customer sheet and to copy the line/s matching onto a new sheet. TIA Rose x

 

[CALLISTAJM]

If this helps, below is the current Macro I use, I want it to do the same but for only people who pay on a certain day of the week entered into column J

Sub overdue()
' Declare Current as a worksheet object variable.
Dim Current As Worksheet
Dim lr As Long
Dim lro As Long
lro = Sheets("overdue").Cells(Rows.Count, 1).End(xlUp).Row 'last row of overdue sheet
If lro = 1 Then 'keep code from erasing the headers.
lro = 2
End If
Sheets("overdue").Range("A2:K" & lro).ClearContents 'clears overdue sheet
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
If Current.Name <> "overdue" Then
lr = Current.Cells(Rows.Count, 1).End(xlUp).Row 'last row of current worksheet
lro = Sheets("overdue").Cells(Rows.Count, 1).End(xlUp).Row
For I = 2 To lr
lro = Sheets("overdue").Cells(Rows.Count, 1).End(xlUp).Row
If Current.Cells(I, 8) = "yes" Then
Sheets("overdue").Cells(lro + 1, 1) = Current.Name 'put customer name (worksheet name) on the overdue sheet
Current.Range("A" & I & ":K" & I).Copy Sheets("overdue").Range("B" & lro + 1) ' copies
End If
Next I

End If

Next
End Sub

Rose x

 

[louisH]

Ignore the first bit of code i sent, it's not correct.

Can you try the following ?
It Worked for me.

Sub test()

Application.ScreenUpdating = False
    
    Dim lastRow, lastRowClient As Long
    Dim c As Range
    
    If IsEmpty(Range("A2")) Then
        lastRow = 2
    Else
        lastRow = Range("A1").End(xlDown).Row
    End If
    
    For Each c In Range("D2:D" & lastRow)
        
        If WorksheetFunction.Weekday(c.Value, 2) = 1 And Cells(c.Row, 3).Value <= Date Then
            
            If IsEmpty(Worksheets("Customer Name").Range("A2")) Then
                lastRowClient = 2
            Else
                lastRowClient = Worksheets("Customer Name").Range("A1").End(xlDown).Row + 1
            End If
            
            Range("A" & c.Row & ":J" & c.Row).Copy
            Worksheets("Customer Name").Range("A" & lastRowClient).PasteSpecial
            Application.CutCopyMode = False
            
        End If
    
    Next c
    
Application.ScreenUpdating = True

End Sub

 

[CALLISTAJM]

Ignore the first bit of code i sent, it's not correct.

Can you try the following ?
It Worked for me.

Sub test()

Application.ScreenUpdating = False
    
    Dim lastRow, lastRowClient As Long
    Dim c As Range
    
    If IsEmpty(Range("A2")) Then
        lastRow = 2
    Else
        lastRow = Range("A1").End(xlDown).Row
    End If
    
    For Each c In Range("D2:D" & lastRow)
        
        If WorksheetFunction.Weekday(c.Value, 2) = 1 And Cells(c.Row, 3).Value <= Date Then
            
            If IsEmpty(Worksheets("Customer Name").Range("A2")) Then
                lastRowClient = 2
            Else
                lastRowClient = Worksheets("Customer Name").Range("A1").End(xlDown).Row + 1
            End If
            
            Range("A" & c.Row & ":J" & c.Row).Copy
            Worksheets("Customer Name").Range("A" & lastRowClient).PasteSpecial
            Application.CutCopyMode = False
            
        End If
    
    Next c
    
Application.ScreenUpdating = True

End Sub

I entered it and changed the 'D's for 'J' (the column I need it to identify with customers payment date) its runs with no error message but nothing shows up?

TIA Rose x

 

[CALLISTAJM]

I have worked out that I can use the macro i currently use:

Sub overdue()
' Declare Current as a worksheet object variable.
Dim Current As Worksheet
Dim lr As Long
Dim lro As Long
lro = Sheets("overdue").Cells(Rows.Count, 1).End(xlUp).Row 'last row of overdue sheet
If lro = 1 Then 'keep code from erasing the headers.
lro = 2
End If
Sheets("overdue").Range("A2:K" & lro).ClearContents 'clears overdue sheet
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
If Current.Name <> "overdue" Then
lr = Current.Cells(Rows.Count, 1).End(xlUp).Row 'last row of current worksheet
lro = Sheets("overdue").Cells(Rows.Count, 1).End(xlUp).Row
For I = 2 To lr
lro = Sheets("overdue").Cells(Rows.Count, 1).End(xlUp).Row
If Current.Cells(I, 8) = "yes" Then
Sheets("overdue").Cells(lro + 1, 1) = Current.Name 'put customer name (worksheet name) on the overdue sheet
Current.Range("A" & I & ":K" & I).Copy Sheets("overdue").Range("B" & lro + 1) ' copies
End If
Next I

End If

Next
End Sub

But At the moment its only lists If Current.Cells(I, 8) = "yes" Then ....... I need it to be If Current.Cells(I, 8) = "yes" AND if J = "Monday"

Can you help me add that extra code in, TIA Rose x

 

[louisH]

Yes i assumed PMT Date was column D. So if it's actually J then you might as well change the rest of the Ranges

Assuming I is your "Invoice Date" Column and you want to copy columns G to P. I added comments so you know what ranges to change.

Sub test()

Application.ScreenUpdating = False
    
    Dim lastRow, lastRowClient As Long
    Dim c As Range
    
'Counting how many rows you have in the first sheet

    If IsEmpty(Range("J2")) Then
        lastRow = 2
    Else
        lastRow = Range("J1").End(xlDown).Row
    End If
    
    For Each c In Range("J2:J" & lastRow)
        
'For Each row check if column J is monday, and if column I is today or earlier

        If WorksheetFunction.Weekday(c.Value, 2) = 1 And Range("I" & c.Row).Value <= Date Then
            
            If IsEmpty(Worksheets("Customer Name").Range("A2")) Then
                lastRowClient = 2
            Else
                lastRowClient = Worksheets("Customer Name").Range("A1").End(xlDown).Row + 1
            End If
            
'Copy columns G to P of the row

            Range("G" & c.Row & ":P" & c.Row).Copy

'Paste the copied columns in column A of the other sheet called "Customer Name"

            Worksheets("Customer Name").Range("A" & lastRowClient).PasteSpecial
            Application.CutCopyMode = False
            
        End If
    
    Next c
    
Application.ScreenUpdating = True

End Sub

 

[louisH]

If Current.Cells(I, 8) = "yes" [/SIZE]AND if J = "Monday"

Ok. So this will test if the date is monday.

If Current.Cells(I, 8) = "yes" And WorksheetFunction.Weekday(Current.Cells(I, 10).Value, 2) = 1 Then 
'...

If 10 is the PMT Date Column