1. Range has blank cells stop macro & instead error message 2. Today()+4 when its Thursda

[bkramer1]

Hello thank you for coming to my Aid!

I have a nifty VBA that someone from Excelforum created for me. However there are a couple tweaks I'd like to make in order to perfect it.

(1). I'd like that if any cells in within the range "O2:O199" on worksheet "List of Accounts" are blank don't run the remainder of Macro and instead show a message box with the cell addresses O2-O199 necessary to add data in. If it's work intensive to specify the cell addresses of missing data, a error message saying that there is a blank cell within that range works just as well for me.

(2). If Cell "N2" on worksheet "List of Accounts" is Thursday then have this line of VBA coding (in the VBA code below) """""""shtL.Range("N2:N199") = Int(Now()) + 1""""" update to reflect Today()+4 in other words give me the following Monday's date. If it isn't Thursday than "N2:N199" should increase to Today()+1. This is formula I would have written if it was a formula fix and not a VBA fix. =IF(WEEKDAY(N2)+1=6,TODAY()+4,TODAY()+1)

Thank you very much!!!


Sub Pivot_Refresh()

Dim Table As PivotTable
Set Table = ActiveSheet.PivotTables("PivotTable3")

Table.RefreshTable

Dim shtP As Worksheet
Dim shtL As Worksheet
Dim shtC As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim DateString As String
Dim LRow1 As Long
Dim LRow2 As Long

Set shtP = Sheets("Pivot")
Set shtL = Sheets("List of all Accounts")
Set shtC = Sheets("1.11.22 Log")
Set pt = shtP.PivotTables("PivotTable3")
Set pf = pt.PivotFields("date")
DateString = Format(Now(), "m/d/yyyy")
LRow1 = shtL.Range("A" & Rows.Count).End(xlUp).Row + 1

ActiveSheet.PivotTables ("PivotTable3")

For Each pi In pf.PivotItems
If pi.Value <> DateString Then
End If
Next pi

shtL.Range("A2:O199").Copy shtL.Cells(LRow1, "A")

LRow2 = shtL.Range("A" & Rows.Count).End(xlUp).Row
shtL.Range("N2:N199") = Int(Now()) + 1

shtL.Range("O2:O199").ClearContents

MsgBox "Now Filter B1 to todays Date"

End Sub

[bkramer1]

Played around with the VBA a little and ended up going with the following which although I'm sure I could clean up it works for my purposes.

Sub Pivot_Refresh()

Dim ws As Worksheet
Set ws = Worksheets("List of all accounts")
If ws.Application.WorksheetFunction.CountBlank(ws.Range("O2:O199")) > 0 Then
MsgBox "There Are Blank Cells in Range O2:O199"
Else

Dim Table As PivotTable
Set Table = ActiveSheet.PivotTables("PivotTable3")

Table.RefreshTable

Dim shtP As Worksheet
Dim shtL As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim DateString As String
Dim LRow1 As Long
Dim LRow2 As Long

Set shtP = Sheets("Pivot")
Set shtL = Sheets("List of all Accounts")
Set pt = shtP.PivotTables("PivotTable3")
Set pf = pt.PivotFields("date")
DateString = Format(Now(), "m/d/yyyy")
LRow1 = shtL.Range("A" & Rows.Count).End(xlUp).Row + 1

ActiveSheet.PivotTables ("PivotTable3")

For Each pi In pf.PivotItems
If pi.Value <> DateString Then
End If
Next pi

shtL.Range("A2:O199").Copy shtL.Cells(LRow1, "A")

LRow2 = shtL.Range("A" & Rows.Count).End(xlUp).Row

If ws.Application.WorksheetFunction.Weekday(ws.Range("N2") + 1) = 6 Then
shtL.Range("N2:N199") = Int(Now()) + 4
Else

shtL.Range("N2:N199") = Int(Now()) + 1
End If

shtL.Range("O2:O199").ClearContents

MsgBox "Now Filter B1 to todays Date"
End If

End Sub