To run a macro at schedule time

If you want to keep your workbook open and run code at a specified time, later on, then try this..
Insert a new code module to your project -or- use one that you already have in your project.
Create a scheduler subroutine as shown below:

Sub Scheduler()

'-- RUNS SUB(S) (OR FUNCTIONS) AT TIME SCHEDULED.

    Application.OnTime TimeValue("11:46:40"), "TheScheduledSub"

End Sub

Create a subroutine (or function) that you want to run. Here is one for this example:

Sub TheScheduledSub()

    Debug.Print "TheScheduledSub() has run at " & Time

End Sub

Scheduler() will execute TheScheduledSub() at the exact time specified inside Scheduler(), defined by TimeValue. You can read more about TimeValue here.

You could probably pass the time value you want the Scheduler() sub to execute your sub(s) or function(s) in as a parameter in the sub.
You could probably run a sub 5 hours from now, lets say. I.E. Application.OnTime Now + TimeValue("05:00:00"), "TheScheduledSub"

Copy all mail contents from Outlook to excel sheets separate by each Column

To copy all the mail contents from outlook to excel in separate column, please do the following:

1. Copy the below code in outlook
2. Crate a file in C folder
3. run the macro from Outlook
4. Results will be in excel

The Macro code is:


Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Sample.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
    Application.StatusBar = "Please wait while Excel source is opened ... "
    Set xlApp = CreateObject("Excel.Application")
    bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
 rCount = xlSheet.UsedRange.Rows.Count
'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
 
    rCount = rCount + 1

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
        If InStr(1, vText(i), "Name:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("A" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Email:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Phone:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("C" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Address:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Event:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Location:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("F" & rCount) = Trim(vItem(1))
        End If

       
    Next i

    xlWB.Save
   
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
    xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

To open Excel or CSV from another Excel macro

Here is the code:

Filt = "Excel Files (*.xlsx),*.xlsx,Excel Files (*.xls),*.xls"
FilterIndex = 5
Title = "File 1"
Filename = Application.GetOpenFilename(FileFilter:=Filt, _
FilterIndex:=FilterIndex, Title:=Title)
 Workbooks.Open (FileName)



 To get the file name


P = WorksheetFunction.Substitute(FileName, Left(FileName, InStrRev(FileName, "\")), "")

To automate google search and provide top 10 links

If you would like automate the Google search and would like to know what are all the top 10 websites for the particular search, Here is the macro that automate all your Google searches:

Macro Code:

'' Change this if you want rankings for a region-specific google website, like www.google.co.uk
'' Or, change it to a specific data center IP, like the Caffeine test server: 209.85.225.103
Const GOOGLE_WEBSERVER = "www.google.com"

'' Amount of default-sized result pages to scan
Const PagesToScan = 1

'' Builds the URL of a SERP for a term, starting at a certain result
Function BuildSERPURL(ByVal term As String, ByVal start As Long) As String
BuildSERPURL = "http://" & GOOGLE_WEBSERVER & "/search?start=" & start & "&q=" & term
End Function

'' Fetches a page from the internet
Function FetchPage(ByVal url As String) As String
Dim req As WinHttp.WinHttpRequest
Set req = New WinHttp.WinHttpRequest
req.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
req.Open "GET", url
req.Send
FetchPage = req.ResponseText
End Function

'' Separates and retrieves the hostname from a URL
Function GetHostname(ByVal url As String)
GetHostname = url
End Function

'' Finds an empty row for a new competitor site. Returns the row index
Function FindNextRow()
For Each cell In ActiveSheet.Columns(2).Cells
If Len(cell.Text) < 1 Then
FindNextRow = cell.row
Exit Function
End If
Next
FindNextRow = -1
End Function

'' Processes a single search term
Sub ProcessTerm(ByVal term As String, ByVal myurl As String)
Dim sheet As Worksheet
Dim url As String, contents As String
Dim row As Long, start As Long, page As Long
Dim foundMyUrl As Boolean

Set sheet = Application.ActiveSheet
start = 0
foundMyUrl = False
For page = 1 To PagesToScan
url = BuildSERPURL(term, start)
contents = FetchPage(url)

Dim pos As Long, posEnd As Long
pos = 1
pos2 = 1
Const sig = "

Const Sig2 = "')"">"

'' Find first link
pos = InStr(pos, contents, sig)
pos2 = InStr(pos, contents, Sig2)


While (pos > 0)

pos = pos + Len(sig)
pos2 = pos2 + Len(Sig2)


'' Find end of link
posEnd = InStr(pos, contents, """")
posEnd2 = InStr(pos2, contents, "

")
If posEnd < 1 Then
MsgBox "Failed to parse Google results page"
Exit Sub
End If

'' Extract the URL from the link
url = Mid(contents, pos, posEnd - pos)
a = Mid(contents, pos2, posEnd2 - pos2)

start = start + 1

'If InStr(url, myurl) > 0 Then
'' This my URL. Everything from here on is below me
'foundMyUrl = True
'Else
hostname = GetHostname(url)
row = -1

'' Locate this competitor URL in the existing list
On Error Resume Next
'row = Application.WorksheetFunction.Match(hostname, sheet.Columns(3), 0)
On Error GoTo 0

If row < 2 Then
'' This competitor does not already exist, so add a new row for it
row = FindNextRow
sheet.Cells(row, 2).Value = hostname
sheet.Cells(row, 3).Value = a
'sheet.Cells(row, 5).Value = 0
'' Row exists
End If

'' Count this appearance either below or above me
'If foundMyUrl Then
' sheet.Cells(row, 5).Value = sheet.Cells(row, 5).Value + 1
' Else
'sheet.Cells(row, 4).Value = sheet.Cells(row, 4).Value + 1
'End If
' End If

'' Find next link
pos = InStr(pos, contents, sig)
pos2 = InStr(pos2, contents, Sig2)
Wend
sheet.Cells(row, 2).ClearContents
sheet.Cells(row, 3).ClearContents
Next

Columns("C:C").Select
Selection.Replace What:="", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Range("A1").Select

End Sub

'' Main routine
Sub CompetitorResearch()
Dim sheet As Worksheet
Set sheet = Application.ActiveSheet

'' Retrieve my url
Dim myurl As String
myurl = sheet.Cells(2, 1).Text

'' Work through the list of search terms and process each one
row = 2
While (sheet.Cells(row, 1).Text <> "")
Dim term As String
term = sheet.Cells(row, 1).Text
ProcessTerm term, myurl
row = row + 1
Wend

'' Order the result list by "Above me" and then by "Below me", so stronger competitors appear first

'sheet.Range("C:E").Sort sheet.Columns(4), xlDescending, _
sheet.Columns(5), , xlDescending, _
, , xlYes

End Sub

To Copy Charts from Excel to PPT using Macro

Using macro you can automate the process of copy the ranges and charts from excel to PPT.

The sample code is :

Sub Chart2PPT()
Dim objPPT As Object
Dim objPrs As Object
Dim objSld As Object
Dim shtTemp As Object
Dim chtTemp As ChartObject
Dim objShape As Shape
Dim objGShape As Shape
Dim intSlide As Integer
Dim blnCopy As Boolean

Set objPPT = CreateObject("Powerpoint.application")
objPPT.Visible = True
objPPT.Presentations.Add
objPPT.ActiveWindow.ViewType = 1 'ppViewSlide

For Each shtTemp In ThisWorkbook.Sheets
blnCopy = False
If shtTemp.Type = xlWorksheet Then
For Each objShape In shtTemp.Shapes 'chtTemp In shtTemp.ChartObjects
blnCopy = False
If objShape.Type = msoGroup Then
' if ANY item in group is a chart
For Each objGShape In objShape.GroupItems
If objGShape.Type = msoChart Then
blnCopy = True
Exit For
End If
Next
End If
If objShape.Type = msoChart Then blnCopy = True

If blnCopy Then
intSlide = intSlide + 1
objShape.CopyPicture
' new slide for each chart
objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
objPPT.ActiveWindow.View.Paste
End If
Next
If Not blnCopy Then
' copy used range
intSlide = intSlide + 1
shtTemp.UsedRange.CopyPicture
' new slide for each chart
objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
objPPT.ActiveWindow.View.Paste
End If
Else
intSlide = intSlide + 1
shtTemp.CopyPicture
' new slide for each chart
objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
objPPT.ActiveWindow.View.Paste
End If
Next

Set objPrs = Nothing
Set objPPT = Nothing
End Sub

Introduction to Macro

When you find yourself repeatedly performing the same actions or tasks in your spreadsheets, it might be time for you to create a macro. A macro is a recording of each command and action you perform to complete a task. Then, whenever you need to carry out that task in your spreadsheets, you just run the macro instead.

Macros can be activate by a couple of keystrokes or by a worksheet button so they are easy to execute, and, provided they were recorded correctly, they will always carry out the same steps in the same order with no chance for operator error.

Although complex macros can be created in Excel using the Macro editor, it also possible to create relatively simple ones using the Excel macro recorder. If you are new to using macros in your spreadsheets, this is the right place for you to learn macros