1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA - Auto Email from Cell Value

Discussion in 'VBA Macros' started by Mikee85, Nov 8, 2017.

  1. Mikee85

    Mikee85 New Member

    Messages:
    9
    Hi,

    Could someone help me with my query please? I have attached a sample spreadsheet for reference.

    I’m a novice at VBA (very, very Basic understanding of VBA) and have tried multiple attempts with no avail.

    I would like to create a VBA code to allow me to do the following;


    Ø Check Column K (follow up date) and see if the any cells match todays date.

    Ø If query is satisfied it has found a cell with todays date, then send an email automatically to an addressee.

    Ø Email to include, a comment and use information from that same row from columns C & D new line and then Previous Comments: = Column L.

    Ø Once this has been done, it can only be sent once until that cell is then amended (normally a future date, and when that date becomes todays date it would send again) so the same emails are not sent every time the spreadsheet is opened in that day.

    Ø This to be effective across 6 worksheets within the same work book.

    Secondary query, I would also like for a query for Column G. If the date in column G is older than todays’ date (yesterday and back), then entire row is moved to ‘Archive’ worksheet on the next available row and the worksheet where the row was moved from is deleted so the spreadsheet doesn’t contain multiple gaps.

    Is this possible as I’ve tried multiple versions but as I have limited experience I’m stuck.


    Thank you so much in advance for any help provided.

    Kind regards

    Attached Files:

  2. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    Welcome to the forum!

    I guess the email would be to yourself? There is no field for "addressee". Send one email for all or one per row? Send as plain text, or html which can include signature, or WordEditor method which can include custom signature from RTF file?
  3. Mikee85

    Mikee85 New Member

    Messages:
    9
    Hi Kenneth,

    Thank you for your reply. Yes email to myself and one other.

    HTML & separate Email for each row please!

    Thank you
  4. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    I haven't forgotten about this. I will post some code later this afternoon most likely.
  5. Mikee85

    Mikee85 New Member

    Messages:
    9
    hi Kenneth

    That's great thank you. I look forward to seeing it.
  6. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    Here is part one, the email part.

    Change values in the INPUT area to suit. Note the path and name for your signature.htm file. I am not a big fan of the htmlBody method since the signature htm file data with graphics does not come in well. I prefer the WordEditor method.

    When you see double double quotes, that means that (BR) was inside but ()'s are <>'s. This is because text here is html. BR with the <> signs is html for vbCrLf.

    Look at the construction of the subj (subject) and bod (body). Once you run it, you can see what you might want to change. I recommend just doing one row with the date in column K as today to test. Once it works, uncomment Send and comment out Display or delete it.

    Remove the trailing space character in your tab name "Archive " or change code to use that name.

    Code (vb):
    Sub Main1() 'Send emails for each row in each sheet where column K/11=Today
     Dim ws As Worksheet, aws As Worksheet, i As Long, j As Integer, calc As Integer
      Dim T$, CC$, td As Date, r As Range, rr As Range, sig$, htmSig$, rw As Long
      Dim subj$, bod$
      Dim OutApp As Object, OutEmail As Object
      'Tools > References > Microsoft Outlook xx.0 Object Library
     'Dim OutApp As New Outlook.Application, OutEmail As Outlook.MailItem

    '*********** Set Inputs *************************************************
     T = "ken@gmail.com"
      CC = "ken@yahoo.com"
      htmSig = "std"
    '*********** End Inputs *************************************************

      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
      End With

      'signature, http://www.rondebruin.nl/win/s1/outlook/signature.htm
     sig = Environ("appdata") & "\Microsoft\Signatures\" & htmSig & ".htm"
      If Dir(sig) <> "" Then
        sig = GetBoiler(sig)  'Get html text.
       Else: sig = ""
      End If

      td = Date 'Today
     Set aws = Worksheets("Archive")

      Set OutApp = CreateObject("Outlook.Application")

      'With OutEmail
     For j = 1 To aws.Index - 1
        Set ws = Worksheets(j)
        With ws
          If .AutoFilterMode = True Then .AutoFilterMode = False
          .UsedRange.AutoFilter 11, td
          Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
          If r.Areas.Count = 1 Then GoTo NextJ  'No data in filter.
         For Each rr In r.Areas
            If rr.Row = 1 Then GoTo NextRR  'Skip row 1 - header row
           'Add a day, prevents another run today.
           rr(, 11).Value = rr(, 11).Value + 1
            subj = .Range("C1").Value & ":  " & rr(, 3).Value & " is due today."
            bod = .Range("C1").Value & ":  " & rr(, 3).Value & "<BR>"
            bod = bod & .Range("D1").Value & ":  " & rr(, 4).Value & "<BR>"
            bod = bod & "<BR>" & .Range("L1").Value & ":  " & rr(, 12).Value & "<BR>"
            bod = bod & sig
            Set OutEmail = OutApp.CreateItem(0)  '0=olMailItem
           With OutEmail
              .BodyFormat = 2 'olFormatHTML=2, not really needed.
             .Display
              'If range to html needed, http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
             .HTMLBody = bod
              .To = T
              .CC = CC
              .subject = subj
              '.Send
             .Display
            End With
    NextRR:
          Next rr
          .AutoFilter.ShowAllData
        End With
    NextJ:
      Next j

      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
        .CutCopyMode = False
      End With
      On Error Resume Next
      Set OutEmail = Nothing
      Set OutApp = Nothing
    End Sub


    Function GetBoiler(ByVal sFile As String) As String
    'Dick Kusleika
       Dim fso As Object
        Dim ts As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
        GetBoiler = ts.readall
        ts.Close
    End Function
     
    Last edited: Nov 9, 2017
  7. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    As always but especially with this one, test on a backup copy.

    Code (vb):
    Sub Main2() 'Archive rows to Archive Sheet
     Dim ws As Worksheet, aws As Worksheet, i As Long
      Dim j As Integer, calc As Integer
      Dim td As Date, r As Range, rr As Range
     
      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
      End With
      td = Date 'Today
     Set aws = Worksheets("Archive")
     
      For j = 1 To aws.Index - 1
        Set ws = Worksheets(j)
        With ws
          If .AutoFilterMode = True Then .AutoFilterMode = False
          .UsedRange.AutoFilter 7, "<" & td
          Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
          Set r = Intersect(r, .Rows("2:" & .Rows.Count))
          If Not r Is Nothing Then
            r.Copy aws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
            r.Delete xlUp
            .AutoFilter.ShowAllData
          End If
        End With
    NextJ:
      Next j
     
      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
        .CutCopyMode = False
      End With
    End Sub

     
    Chirag R Raval likes this.
  8. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    This is a tweak to post #6.
    Code (vb):
    Sub Main1() 'Send emails for each row in each sheet where column K/11=Today
     Dim ws As Worksheet, aws As Worksheet, i As Long, j As Integer, calc As Integer
      Dim T$, CC$, td As Date, r As Range, rr As Range, sig$, htmSig$, rw As Range
      Dim subj$, bod$
      Dim OutApp As Object, OutEmail As Object
      'Tools > References > Microsoft Outlook xx.0 Object Library
     'Dim OutApp As New Outlook.Application, OutEmail As Outlook.MailItem

    '*********** Set Inputs *************************************************
     T = "ken@gmail.com"
      CC = "ken@yahoo.com"
      htmSig = "std"
    '*********** End Inputs *************************************************

      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
      End With

      'signature, http://www.rondebruin.nl/win/s1/outlook/signature.htm
     sig = Environ("appdata") & "\Microsoft\Signatures\" & htmSig & ".htm"
      If Dir(sig) <> "" Then
        sig = GetBoiler(sig)  'Get html text.
       Else: sig = ""
      End If
     
      td = Date 'Today
     Set aws = Worksheets("Archive")
     
      Set OutApp = CreateObject("Outlook.Application")
     
      'With OutEmail
     For j = 1 To aws.Index - 1
        Set ws = Worksheets(j)
        With ws
          If .AutoFilterMode = True Then .AutoFilterMode = False
          .UsedRange.AutoFilter 11, td
          Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
          If r.Areas.Count = 1 Then GoTo NextJ  'No data in filter.
         For Each rr In r.Areas
            If rr.Row = 1 Then GoTo NextRR  'Skip row 1 - header row
           For Each rw In rr.Rows
              'Add a day, prevents another run today.
             rw.Cells(, 11).Value = rw.Cells(, 11).Value + 1
              subj = .Range("C1").Value & ":  " & rw.Cells(, 3).Value & " is due today."
              bod = .Range("C1").Value & ":  " & rw.Cells(, 3).Value & "<BR>"
              bod = bod & .Range("D1").Value & ":  " & rw.Cells(, 4).Value & "<BR>"
              bod = bod & "<BR>" & .Range("L1").Value & ":  " & rw.Cells(, 12).Value & "<BR>"
              bod = bod & sig
              Set OutEmail = OutApp.CreateItem(0)  '0=olMailItem
             With OutEmail
                .BodyFormat = 2 'olFormatHTML=2, not really needed.
               .Display
                'If range to html needed, http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
               .HTMLBody = bod
                .To = T
                .CC = CC
                .subject = subj
                '.Send
               .Display
              End With
            Next rw
    NextRR:
          Next rr
          .AutoFilter.ShowAllData
        End With
    NextJ:
      Next j
     
      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
        .CutCopyMode = False
      End With
      On Error Resume Next
      Set OutEmail = Nothing
      Set OutApp = Nothing
    End Sub
    Chirag R Raval likes this.
  9. Mikee85

    Mikee85 New Member

    Messages:
    9
    Hi Kenneth,

    Thank you for the coding above and your expertise, it is greatly appreciated.

    I have entered the code and ran the spreadsheet but it doesn't seem to work. The rows have all closed up to row 128 when the end date in column G is applied including the title.

    The email doesn't seem to populate / Display with today's date. I'm happy for it not to be HTML is there is much easier and better method.

    Would you be to take a look at this for again please?

    Thank you in advance

    Attached Files:

  10. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    1. Put the code into a Module, not ThisWorkbook and not a Sheet object.

    I added the GetBoiler() routine, and changed the Loop exit.

    Change the TO (T variable value) back to your TO.

    Code (vb):
    Sub Main1() 'Send emails for each row in each sheet where column K/11=Today
    Dim ws As Worksheet, aws As Worksheet, i As Long, j As Integer, calc As Integer
      Dim T$, CC$, td As Date, r As Range, rr As Range, sig$, htmSig$, rw As Range
      Dim subj$, bod$
      Dim OutApp As Object, OutEmail As Object
      'Tools > References > Microsoft Outlook xx.0 Object Library
    'Dim OutApp As New Outlook.Application, OutEmail As Outlook.MailItem

    '*********** Set Inputs *************************************************
    T = "ken@hotmail.co.uk"
      CC = ""
      htmSig = "std"
    '*********** End Inputs *************************************************

      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
      End With

      'signature, http://www.rondebruin.nl/win/s1/outlook/signature.htm
    sig = Environ("appdata") & "\Microsoft\Signatures\" & htmSig & ".htm"
      If Dir(sig) <> "" Then
        sig = (sig)  'Get html text.
     Else: sig = ""
      End If
      td = Date 'Today
    Set aws = Worksheets("Archive")
      Set OutApp = CreateObject("Outlook.Application")
      'With OutEmail
    For j = 1 To aws.Index - 1
        Set ws = Worksheets(j)
        With ws
          If .AutoFilterMode = True Then .AutoFilterMode = False
          .UsedRange.AutoFilter 11, td
        Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
        For Each rr In r.Areas
          For Each rw In rr.Rows
              If rw.Row = 1 Then GoTo NextRW
              'Add a day, prevents another run today.
           rw.Cells(, 11).Value = rw.Cells(, 11).Value + 1
              subj = .Range("C1").Value & ":  " & rw.Cells(, 3).Value & " is due today."
              bod = .Range("C1").Value & ":  " & rw.Cells(, 3).Value & "<BR>"
              bod = bod & .Range("D1").Value & ":  " & rw.Cells(, 4).Value & "<BR>"
              bod = bod & "<BR>" & .Range("L1").Value & ":  " & rw.Cells(, 12).Value & "<BR>"
              bod = bod & sig
              Set OutEmail = OutApp.CreateItem(0)  '0=olMailItem
           With OutEmail
                .BodyFormat = 2 'olFormatHTML=2, not really needed.
             .Display
                'If range to html needed, http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
             .HTMLBody = bod
                .To = T
                .CC = CC
                .Subject = subj
                '.Send
             .Display
              End With
    NextRW:
            Next rw
          Next rr
          .AutoFilter.ShowAllData
        End With
      Next j
      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
        .CutCopyMode = False
      End With
      On Error Resume Next
      Set OutEmail = Nothing
      Set OutApp = Nothing
    End Sub

    Sub Main2() 'Archive rows to Archive Sheet
    Dim ws As Worksheet, aws As Worksheet, i As Long
      Dim j As Integer, calc As Integer
      Dim td As Date, r As Range, rr As Range
      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
      End With
      td = Date 'Today
    Set aws = Worksheets("Archive")
      For j = 1 To aws.Index - 1
        Set ws = Worksheets(j)
        With ws
          If .AutoFilterMode = True Then .AutoFilterMode = False
          .UsedRange.AutoFilter 7, "<" & td
          Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
          Set r = Intersect(r, .Rows("2:" & .Rows.Count))
          If Not r Is Nothing Then
            r.Copy aws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
            r.Delete xlUp
            .AutoFilter.ShowAllData
          End If
        End With
    NextJ:
      Next j
      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
        .CutCopyMode = False
      End With
    End Sub

    'signature, http://www.rondebruin.nl/win/s1/outlook/signature.htm
    Function GetBoiler(ByVal sFile As String) As String
    'Dick Kusleika
       Dim fso As Object
        Dim ts As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
        GetBoiler = ts.readall
        ts.Close
    End Function
    Chirag R Raval likes this.
  11. Mikee85

    Mikee85 New Member

    Messages:
    9
    That's great thank you.

    The spreadsheet edits and moves across to the other archive sheet when i run it.

    The email still doesn't seem to work, however i'll put in the data and will try open it tomorrow and see if that works.

    Thank you again for your help and expertise.
  12. Mikee85

    Mikee85 New Member

    Messages:
    9
    Added the code as above and added as module.

    The data transfers perfectly to the archive if the date has elapsed. However, the email function is still not working.

    Sorry to be a pain, but would you be able to have another look for me please?

    Thank you in advance

    Mike

    Attached Files:

  13. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    It "worked" for me.

    I noticed that I had left out the call to GetBoiler() but it still displayed the email.
    Code (vb):
    sig = GetBoiler(sig)  'Get html text.
    Of course once it runs, it updates column K's today's date by one.
  14. Mikee85

    Mikee85 New Member

    Messages:
    9
    Hi Kenneth,

    I'm really unsure what is going on. The email still doesn't populate and the get boiler routine is flagging up as an error. I've tried different dates over different days to check, just in case the routine to stop it sending twice was stopping it.

    The transfer of rows to archive seems to work perfectly.

    sorry to be a pain, is there another way this could work, doesn't have to be HTML, plain text is ok.

    Thank you again in advance

    Mike
  15. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    HTML is not the problem for Main1() Display/Send.

    K2 date should be today, Ctrl+:. I did that in your post #12 file and fixed GetBoiler as detailed in post #13. It worked fine.

    At this point, you may want to press F8 in Main1() to execute each line to see where it might be a problem for you. Of course if none of the sheets filter K column to today, then it won't "work".

    You can easily test if the filter returns column K values of Today/Date:
    Code (vb):
    Sub Test()
      Sheet3.UsedRange.AutoFilter 11, Date
    End Sub
    sig/Getboiler issue:
    Press Win+E, type %AppData%, press Enter key, and navigate to Microsoft\Signatures. You should see your sig.htm and sig.rtf files there. The sig part is STD in my example. The actual sig variable will contain the full path to it. All you have to do is insert your basefilename for your signature file. There can be more than one in that folder.
    Last edited: Nov 13, 2017
  16. Mikee85

    Mikee85 New Member

    Messages:
    9
    Hi Kenneth,

    I've done the test and it it give's a 'Run time error '1004':
    AutoFilter method of range class failed.

    This was done on a copy of my main spreadsheet and the cut and paste function wont work now either. It seems the filter is filtering the end date column, but not actually ticking the box for a date so no data shows which in turn i think causes the error.

    This may also explain why the email is not populating as there filter will show no dates, even when today's date is there. using the F8 method as above, it does a loop through each worksheet but never goes on to the email information bit to allow it to do its bit.

    Thank you again so much for your patience and help.
  17. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    Sounds like your column data is not a Date value. Ctrl+1 lets view the number format quickly. Post a file with more than just the one example. Maybe do 4 or 5 rows.

    I have seen some data where the date format was critical for a proper autofilter. I had to do the filter by a date string using Format().

    My tests with 5 rows and 2 with today's date worked as expected.
  18. Mikee85

    Mikee85 New Member

    Messages:
    9
    I've tried again but still nothing. I've attached file in case I've changed something i shouldn't have.

    The columns (G & K) were not in cell date format but now changed. The filter does filter, but doesn't show anything, even with today's date and prior dates until i un filter it back.

    Thank you

    Attached Files:

  19. Kenneth Hobson

    Kenneth Hobson Active Member

    Messages:
    174
    As I thought, since you changed date format, Format() is needed. That format is probably different than your Regional settings. I know it is for me. I fixed GetBoiler() for you as well.

    Be sure to test with backup limited data as I have not fully tested it. You will want to comment out .Display and uncomment .Send when it works as needed.

    Code (vb):
    Sub Main1() 'Send emails for each row in each sheet where column K/11=Today
     Dim ws As Worksheet, aws As Worksheet, i As Long, j As Integer, calc As Integer
      Dim T$, CC$, td As Date, r As Range, rr As Range, sig$, htmSig$, rw As Range
      Dim subj$, bod$
      Dim OutApp As Object, OutEmail As Object
      'Tools > References > Microsoft Outlook xx.0 Object Library
    'Dim OutApp As New Outlook.Application, OutEmail As Outlook.MailItem

    '*********** Set Inputs *************************************************
     T = "ken@hotmail.co.uk"
      CC = ""
      htmSig = "std"
    '*********** End Inputs *************************************************

      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
      End With

      'signature, http://www.rondebruin.nl/win/s1/outlook/signature.htm
     sig = Environ("appdata") & "\Microsoft\Signatures\" & htmSig & ".htm"
      If Dir(sig) <> "" Then
        sig = GetBoiler(sig)  'Get html text.
    Else: sig = ""
      End If
      td = Date 'Today
    Set aws = Worksheets("Archive")
      Set OutApp = CreateObject("Outlook.Application")
      'With OutEmail
    For j = 1 To aws.Index - 1
        Set ws = Worksheets(j)
        With ws
          If .AutoFilterMode = True Then .AutoFilterMode = False
          .UsedRange.AutoFilter 11, Format(td, "dd/mm/yyyy")
        Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
        For Each rr In r.Areas
          For Each rw In rr.Rows
              If rw.Row = 1 Then GoTo NextRW
              'Add a day, prevents another run today.
         rw.Cells(, 11).Value = rw.Cells(, 11).Value + 1
              subj = .Range("C1").Value & ":  " & rw.Cells(, 3).Value & " is due today."
              bod = .Range("C1").Value & ":  " & rw.Cells(, 3).Value & "<BR>"
              bod = bod & .Range("D1").Value & ":  " & rw.Cells(, 4).Value & "<BR>"
              bod = bod & "<BR>" & .Range("L1").Value & ":  " & rw.Cells(, 12).Value & "<BR>"
              bod = bod & sig
              Set OutEmail = OutApp.CreateItem(0)  '0=olMailItem
         With OutEmail
                .BodyFormat = 2 'olFormatHTML=2, not really needed.
           .Display
                'If range to html needed, http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
           .HTMLBody = bod
                .To = T
                .CC = CC
                .Subject = subj
                '.Send
           .Display
              End With
    NextRW:
            Next rw
          Next rr
          .AutoFilter.ShowAllData
        End With
      Next j
      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
        .CutCopyMode = False
      End With
      On Error Resume Next
      Set OutEmail = Nothing
      Set OutApp = Nothing
    End Sub

    Sub Main2() 'Archive rows to Archive Sheet
    Dim ws As Worksheet, aws As Worksheet, i As Long
      Dim j As Integer, calc As Integer
      Dim td As Date, r As Range, rr As Range
      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
      End With
      td = Date 'Today
    Set aws = Worksheets("Archive")
      For j = 1 To aws.Index - 1
        Set ws = Worksheets(j)
        With ws
          If .AutoFilterMode = True Then .AutoFilterMode = False
          .UsedRange.AutoFilter 7, "<" & Format(td, "dd/mm/yyyy")
          Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
          Set r = Intersect(r, .Rows("2:" & .Rows.Count))
          If Not r Is Nothing Then
            r.Copy aws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
            r.Delete xlUp
            .AutoFilter.ShowAllData
          End If
        End With
    NextJ:
      Next j
      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
        .CutCopyMode = False
      End With
    End Sub

    'signature, http://www.rondebruin.nl/win/s1/outlook/signature.htm
    Function GetBoiler(ByVal sFile As String) As String
    'Dick Kusleika
       Dim fso As Object
        Dim ts As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
        GetBoiler = ts.readall
        ts.Close
    End Function
    Sub Test()
      Sheet3.UsedRange.AutoFilter 11, Format(Date, "dd/mm/yyyy")
    End Sub
     

Share This Page