Abort macro if no data

CordingBags

New Member
Joined
Mar 7, 2022
Messages
43
Office Version
  1. 2016
Platform
  1. Windows
I have current macro below, many thanks and all credit to Kevin9999, that generates exactly the outcome I want.
However if there is no data in column F then a debug error occurs and the user is thrown into the VBA interface with which they are unfamiliar.
The user should not run the macro before entering the data but given there are several, be they colour coded macro assigned buttons it can happen.

What I need is a few lines of code at the beginning that effectively checks IF(SUM(F2:F318)<1 then abort macro with message box "No Dates In Column F", "OK"
Guess it could just abort but user would not be aware of why the error

For info column F is data validated to only allow dates, but guess this is pretty irrelevant as they are just numbers to Excel.

Any help appreciated.
Thanks
Paul

Current Macro, thanks and credit to Kevin9999

Sub Prepare_Fixtures_From_TAB()
Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, r As Range, i As Long, d As Date
Set ws1 = ActiveSheet
Set ws2 = Worksheets("FIXTURES")
ws2.Cells.ClearContents
Set rng = ws1.Columns("F")

d = Application.Max(rng)
Set r = rng.Find(d)
i = r.Row

If i > 0 Then
ws1.Range("D1:N" & i + 1).Copy
ws2.Range("D1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If

Sheets("FIXTURES").Select
Range("C1").Select

Range("E3,E6,E9,E12,E15,E18,E21,E24,E27,E30,E33,E36,E39,E42,E45,E48,E51,E54,E57,E60,E63,E66,E69,E72,E75,E78,E81,E84,E87,E90,E93,E96,E99,E102,E105,E108,E111,E114,E117,E120,E123").Clear
Range("E126,E129,E132,E135,E138,E141,E144,E147,E150,E153,E156,E159,E162,E165,E168,E171,E174,E177,E180,E183,E186,E186,E192,E195,E198,E201,E204,E207,E210,E213,E216,E219,E222,E225").Clear
Range("E228,E231,E234,E237,E240,E243,E246,E249,E252,E255,E258,E261,E264,E267,E270,E273,E276,E279,E282,E285,E288,E291,E294,E297,E300,E303,E306,E309,E312,E315,E318").Clear

Range("C1").Select

End Sub
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Maybe something Like this:
VBA Code:
Sub Prepare_Fixtures_From_TAB()
  Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, r As Range, i As Long, d As Date, j As Long
  Set ws1 = ActiveSheet
  Set ws2 = Worksheets("FIXTURES")
  ws2.Cells.ClearContents
  Set = ws1.Columns("F")
  If Application.Sum(rng)>0 Then
    d = Application.Max(rng)
    Set r = rng.Find(d)
    i = r.Row

    If i > 0 Then
      ws1.Range("D1:N" & i + 1).Copy
      ws2.Range("D1").PasteSpecial xlPasteValues
      Application.CutCopyMode = False
    End If

    Sheets("FIXTURES").Select
    Range("C1").Select

    For  j = 3 to 318 Step 3
      Range("E" & j).Clear
    Next

    Range("C1").Select
  End If
End Sub
 
Upvote 0
Flashbond already answered this, but did you want a Msgbox message?

VBA Code:
Sub Prepare_Fixtures_From_TAB()
Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, r As Range, i As Long, d As Date
Set ws1 = ActiveSheet
Set ws2 = Worksheets("FIXTURES")
ws2.Cells.ClearContents
Set rng = ws1.Columns("F")

If Application.Sum(rng) = 0 Then
    MsgBox "No Dates In Column F", , "Error"
    Exit Sub
End If

d = Application.Max(rng)
Set r = rng.Find(d)
i = r.Row

If i > 0 Then
ws1.Range("D1:N" & i + 1).Copy
ws2.Range("D1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If

Sheets("FIXTURES").Select
Range("C1").Select

Range("E3,E6,E9,E12,E15,E18,E21,E24,E27,E30,E33,E36,E39,E42,E45,E48,E51,E54,E57,E60,E63,E66,E69,E72,E75,E78,E81,E84,E87,E90,E93,E96,E99,E102,E105,E108,E111,E114,E117,E120,E123").Clear
Range("E126,E129,E132,E135,E138,E141,E144,E147,E150,E153,E156,E159,E162,E165,E168,E171,E174,E177,E180,E183,E186,E186,E192,E195,E198,E201,E204,E207,E210,E213,E216,E219,E222,E225").Clear
Range("E228,E231,E234,E237,E240,E243,E246,E249,E252,E255,E258,E261,E264,E267,E270,E273,E276,E279,E282,E285,E288,E291,E294,E297,E300,E303,E306,E309,E312,E315,E318").Clear

Range("C1").Select

End Sub
 
Upvote 0
Solution
Maybe something Like this:
VBA Code:
Sub Prepare_Fixtures_From_TAB()
  Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, r As Range, i As Long, d As Date, j As Long
  Set ws1 = ActiveSheet
  Set ws2 = Worksheets("FIXTURES")
  ws2.Cells.ClearContents
  Set = ws1.Columns("F")
  If Application.Sum(rng)>0 Then
    d = Application.Max(rng)
    Set r = rng.Find(d)
    i = r.Row

    If i > 0 Then
      ws1.Range("D1:N" & i + 1).Copy
      ws2.Range("D1").PasteSpecial xlPasteValues
      Application.CutCopyMode = False
    End If

    Sheets("FIXTURES").Select
    Range("C1").Select

    For  j = 3 to 318 Step 3
      Range("E" & j).Clear
    Next

    Range("C1").Select
  End If
End Sub
Hi Flashbond VBA doesn't like "Set = ws1.Columns("F")" and highlights this is red when I paste it in, also generate a compile syntax error on running.
Code by TUPE works perfectly, many thanks to you both for your efforts.
 
Upvote 0

Forum statistics

Threads
1,223,908
Messages
6,175,304
Members
452,633
Latest member
DougMo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top