Email VBA not working

[Jase L]

Sub Mail_sheets()
Dim MyArr As Variant
Dim last As Long
Dim shname As Long
Dim a As Integer
Dim Arr() As String
Dim N As Integer
Dim strdate As String
For a = 1 To 253 Step 3
If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
Exit Sub
End
Application.ScreenUpdating = False
last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
a).End(xlUp).Row
N = 0
For shname = 1 To last
N = N + 1
ReDim Preserve Arr(1 To N)
Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
Next shname
ThisWorkbook.Sheets(Arr).Copy
strdate = Format(Date, "dd-mm-yy") & " " & _
Format(Time, "h-mm-ss")
ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
With ThisWorkbook.Sheets("mail")
MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
a + 1).End(xlUp))
End With
ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
Application.ScreenUpdating = True
Next a
End Sub

Produces an error of Compile Error: Next without For

Any ideas?!

 

[pgc01]

Hi Jase

You don't close the IF block. Instead of

If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
Exit Sub
End

this:

If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
Exit Sub
End If

Hope this helps
PGC

 

[Jase L]

Ah of course!

Thanks!

 

[Norie]

Not 100% sure what you are trying to do but this compiles.

Sub Mail_sheets()
Dim MyArr As Variant
Dim last As Long
Dim shname As Long
Dim a As Integer
Dim Arr() As String
Dim N As Integer
Dim strdate As String

    Application.ScreenUpdating = False
    
    For a = 1 To 253 Step 3
        If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
            Exit Sub
        End If
    
        last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, a).End(xlUp).Row
        
        For shname = 1 To last
            N = N + 1
            ReDim Preserve Arr(1 To N)
            Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
        Next shname
        
        ThisWorkbook.Sheets(Arr).Copy
        strdate = Format(Date, "dd-mm-yy") & " " & Format(Time, "h-mm-ss")
        ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name & " " & strdate & ".xls"
        
        With ThisWorkbook.Sheets("mail")
            MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, a + 1).End(xlUp))
        End With
        
        ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
        ActiveWorkbook.ChangeFileAccess xlReadOnly
        Kill ActiveWorkbook.FullName
        ActiveWorkbook.Close False
        
    Next a
    
    Application.ScreenUpdating = True
    
End Sub