Macro Examples

It's fairly easy to export a spreadsheet to a text file but how about when you only want a range? Well, here you go...

Sub ExportRangeToTextFile()

'get the file name to write to
Dim FName As Variant
FName = Application.GetSaveAsFilename("ExcelData.txt", _
   "Text File (*.txt),*.txt,ASCII File (*.asc),*.asc", _
   1, "Export Range to Text File")
If FName = False Then
    MsgBox "You didn't enter a file name."
    Exit Sub
End If

'open the file for writing
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(FName, True)

'write the data from the range
Dim row, col
row = 0
col = 0
Dim cell As Range
For Each cell In Selection.Cells
   If cell.row <> row Then
      If row <> 0 Then
         f.write Chr(13) & Chr(10)
      End If
      row = cell.row
   End If
   f.write cell.Value
   f.write Chr(9)
Next

'close the file and release objects
f.Close
Set fs = Nothing

End Sub

Put this macro code in your spreadsheet to run a batch job--

Sub ExportToHTMLTable()
    Dim DestFile As String
    Dim FileNum As Integer
    Dim ColumnCount As Integer
    Dim RowCount As Integer

    ' Prompt user for destination file name.
    DestFile = InputBox("Enter the destination filename" & _
      Chr(10) & "(with complete path and extension):", _
      "Quote-Comma Exporter")
    ' Obtain next free file handle number.
    ' DestFile = Application.DefaultFilePath & "\" & DestFile
    FileNum = FreeFile()

    ' Turn error checking off.
    On Error Resume Next

    ' Attempt to open destination file for output.
    Open DestFile For Output As #FileNum
    ' If an error occurs report it and end.
    If Err <> 0 Then
      MsgBox "Cannot open filename " & DestFile
      End
    End If

    ' Turn error checking on.
    On Error GoTo 0

    ' Print the top of the html document
    Print #FileNum, "<html>"
    Print #FileNum, "<head>"
    Print #FileNum,
    Print #FileNum, "<style type=""text/css"">"
    Print #FileNum, "table.tblBasic {"
    Print #FileNum, "   border-width: 1px 1px 1px 1px;"
    Print #FileNum, "   border-spacing: 2px;"
    Print #FileNum, "   border-style: solid solid solid solid;"
    Print #FileNum, "   border-color: black black black black;"
    Print #FileNum, "   border-collapse: collapse;"
    Print #FileNum, "   background-color: white;"
    Print #FileNum, "}"
    Print #FileNum, "table.tblBasic th {"
    Print #FileNum, "   border-width: 1px 1px 1px 1px;"
    Print #FileNum, "   padding: 1px 1px 1px 1px;"
    Print #FileNum, "   border-style: solid solid solid solid;"
    Print #FileNum, "   border-color: black black black black;"
    Print #FileNum, "   background-color: #ffccff;"
    Print #FileNum, "   -moz-border-radius: 0px 0px 0px 0px;"
    Print #FileNum, "}"
    Print #FileNum, "table.tblBasic td {"
    Print #FileNum, "   border-width: 1px 1px 1px 1px;"
    Print #FileNum, "   padding: 1px 1px 1px 1px;"
    Print #FileNum, "   border-style: solid solid solid solid;"
    Print #FileNum, "   border-color: black black black black;"
    Print #FileNum, "   background-color: #ffff99;"
    Print #FileNum, "   -moz-border-radius: 0px 0px 0px 0px;"
    Print #FileNum, "}"
    Print #FileNum, "</style>"
    Print #FileNum,
    Print #FileNum, "</head>"
    Print #FileNum,
    Print #FileNum, "<body>"
    Print #FileNum,
    ' End print top of html document

    Print #FileNum, "<table class=""tblBasic"">"
    ' Loop for each row in selection.
    For RowCount = 1 To Selection.Rows.Count
        Print #FileNum, "<tr>"
      ' Loop for each column in selection.
      For ColumnCount = 1 To Selection.Columns.Count

         ' Write current cell's text to file
         If RowCount = 1 Then
            Print #FileNum, "<th>" & Selection.Cells(RowCount, ColumnCount).Text & "</th>"
         Else
            Print #FileNum, "<td>" & Selection.Cells(RowCount, ColumnCount).Text & "</td>"
         End If
         ' Check if cell is in last column.
         ' If ColumnCount = Selection.Columns.Count Then
            ' If so, then write a blank line.
            ' Print #FileNum,
         'Else
            ' Otherwise, write a comma.
            'Print #FileNum, ",";
         'End If
      ' Start next iteration of ColumnCount loop.
      Next ColumnCount
      Print #FileNum, "</tr>"
    ' Start next iteration of RowCount loop.
    Next RowCount
    Print #FileNum, "</table>"
    
    Print #FileNum, ""
    Print #FileNum, "</body>"
    Print #FileNum, "</html>"
    

    ' Close destination file.
    Close #FileNum
End Sub

Put this macro code in your spreadsheet to run a batch job--

Sub Test()
   Call Shell("c:\documents and settings\mark\my projects\test\excel\test.bat", vbNormalFocus)
End Sub

Then make test.bat look like this--

ftp -s:m.dat

Then make m.dat look like this--

open upload.attbi.com
youracctid
yourpassword
cd test
put test.bat
quit

You could export data to a text file formatted as HTML and use this technique to move it to your web account where it could be viewed by anyone.

I liked the idea of an easy FTP of something generated from an Excel document so I wrote this macro that takes information from the worksheet, formats it as an HTML document and sends it to my FTP server. I did it with a command line FTP client called wcl_ftp located here. I put it in c:\program files\cui. (cui=command user interface and it's where I stash all my command line utilities).

Next create a worksheet called 'Frequently Used Articles' and put category, kb article number and description in rows a, b, c respectively. Include a header row. Here's the spreadsheet with the macro so you don't have to type it all in. You'll need to edit the macro code and put your server name, login name and password in it.

Click this link to view the the macro. (I put it in a text file so it wouldn't blow out the formatting of this page because it's wide in places.)

You could do the same sort of thing with the ftp client that comes with Windows but you'd have to make a script, it wouldn't report errors and you'd get this ugly shell window popping up. I'd rather have it all run as W32's. Plus it's got extra features I like.

Now I can add MS knowledge base articles I like to the worksheet, sort them, edit the descriptions, catagorize them and run the macro and instantly have them available on my site as fast loading static HTML.

Here's the output from the macro up on my site.

Sub SendEmail(CustomerAddress, CustomerMessage)
    
    '--- Set up the Outlook objects.
    Dim objOutlook
    Dim objOutlookMsg
    Dim objOutlookRecip
    Dim objOutlookAttach

    '--- This is required to prevent a name which does not resolve to
    '    an e-mail address from hanging the app.
    On Error Resume Next
    
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    
    With objOutlookMsg
        ' Add the To recipient(s) to the message.
        'Set objOutlookRecip = .Recipients.Add(CustomerAddress)
        .Recipients.Add (CustomerAddress)
        objOutlookRecip.Type = olTo
        
        ' Set the Subject, Body, and Importance of the message.
        .Subject = "Testing 1 2 3..."
        .Body = CustomerMessage
        .Importance = olImportanceHigh  'High importance
        
        ' Add attachments to the message.
        'If Not IsMissing(AttachmentPath) Then
        '    Set objOutlookAttach = .Attachments.Add(AttachmentPath)
        'End If
        
        ' Resolve each Recipient's name.
        'For Each objOutlookRecip In .Recipients
        '    objOutlookRecip.Resolve
        '    If Not objOutlookRecip.Resolve Then
        '        Exit Sub
        '    End If
        'Next
        .Send '--- Send the message.
    
    End With
    
    '--- Remove the message and Outlook application from memory.
    Set objOutlookRecip = Nothing
    Set objOutlookAttach = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing
End Sub

Lately, I had a request to dump all the formulas in a spreadsheet so I put this together. It outputs them into a text file that you name then opens that file in Notepad for viewing.

Sub ExportFormulas()

'get the file name to write to
Dim FName As Variant 'must be variant type for potential boolean result
Dim defpath As String
defpath = Application.DefaultFilePath & "\" & "Formulas.txt"
FName = Application.GetSaveAsFilename(defpath, _
   "Text File (*.txt),*.txt,ASCII File (*.asc),*.asc", _
   1, "Export Formulas to Text File")

If FName = False Then
    MsgBox "You didn't enter a file name."
    Exit Sub
End If
 
'open the file for writing
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(FName, True)
Dim eol As String
eol = Chr(13) & Chr(10)
 
'write the data from the range
Dim s As String
Dim row As Integer
Dim col As Integer
row = 0
col = 0
Dim cell As Range
For Each cell In Selection.Cells
    s = cell.Formula
    If Left(s, 1) = "=" Then
        f.write Replace(cell.Address, "$", "") & ": "
        If cell.HasArray Then
            f.write "{" & s & "}" & eol
        Else
            f.write s & eol
        End If
    End If
Next
 
'close the file and release objects
f.Close
Set fs = Nothing
 
Shell "notepad.exe " & FName, vbNormalFocus
 
End Sub

Sometimes a straight connection to an ODBC Data Source Name (DSN) is the the most expedient way to deal with getting data. So I'm going to start adding some macros to do stuff with data using the ODBC middleware. Here's the first--

Private Declare Function SQLDataSources Lib "ODBC32.DLL" _
   (ByVal henv As Long, ByVal fdir As Integer, _
   ByVal szDSN As String, ByVal cbDSNMax As Integer, _
   pcbDSN As Integer, ByVal szDesc As String, _
   ByVal cbDescMax As Integer, pcbDesc As Integer) As Integer
Private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
Const SQL_SUCCESS As Long = 0
Const SQL_FETCH_NEXT As Long = 1

Public Sub RetrieveDSNs()

Dim i As Integer
Dim sDSNItem As String * 1024
Dim sDRVItem As String * 1024
Dim sDSN As String
Dim iDSNLen As Integer
Dim iDRVLen As Integer
Dim lHenv As Long     'handle to the environment
Dim l As Long

If SQLAllocEnv(lHenv) <> -1 Then
    l = 0
    Do Until i <> SQL_SUCCESS
        sDSNItem = Space(1024)
        sDRVItem = Space(1024)
        i = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)
        sDSN = Left(sDSNItem, iDSNLen)
        If sDSN <> Space(iDSNLen) Then
            ActiveCell.Offset(l, 0).Value = sDSN
            l = l + 1
        End If
    Loop
End If

End Sub

This code came from a post on www.mrexcel.com by MsTom.

Option Explicit

Private Declare Function SQLDataSources Lib "odbc32.dll" _
  (ByVal hEnv As Long, _
   ByVal fDirection As Integer, _
   ByVal szDSN As String, _
   ByVal cbDSNMax As Integer, _
   pcbDSN As Integer, _
   ByVal szDescription As String, _
   ByVal cbDescriptionMax As Integer, _
   pcbDescription As Integer) As Long

Private Declare Function SQLAllocHandle Lib "odbc32.dll" _
  (ByVal HandleType As Integer, _
   ByVal InputHandle As Long, _
   OutputHandlePtr As Long) As Long
   
Private Declare Function SQLSetEnvAttr Lib "odbc32.dll" _
  (ByVal EnvironmentHandle As Long, _
   ByVal dwAttribute As Long, _
   ByVal ValuePtr As Long, _
   ByVal StringLen As Long) As Long
   
Private Declare Function SQLFreeHandle Lib "odbc32.dll" _
  (ByVal HandleType As Integer, _
   ByVal Handle As Long) As Long
                         
Private Const DSN_LEN As Long = 32
Private Const DESC_LENGTH As Long = 128
Private Const FoundOk As Long = 0
Private Const GetNext As Long = 1
Private Const Null_HANDLE As Long = 0
Private Const HANDLE_ENV As Long = 1
Private Const ATTR_ODBC_VERSION As Long = 200
Private Const OV_ODBC3 As Long = 3
Private Const IS_INTEGER As Long = (-6)
Public UserSysStringArray() As String

Sub UserSysDSNs()

Dim hEnv As Long
Dim sServer As String
Dim sDriver As String
Dim nSvrLen As Integer
Dim nDvrLen As Integer
Dim ArrayCntr As Integer
ArrayCntr = 0

If SQLAllocHandle(HANDLE_ENV, _
    Null_HANDLE, hEnv) <> 0 Then
    If SQLSetEnvAttr(hEnv, _
        ATTR_ODBC_VERSION, _
        OV_ODBC3, _
        IS_INTEGER) <> 0 Then
            sServer = Space$(DSN_LEN)
            sDriver = Space$(DESC_LENGTH)
            Do While SQLDataSources(hEnv, _
                GetNext, _
                sServer, _
                DSN_LEN, _
                nSvrLen, _
                sDriver, _
                DESC_LENGTH, _
                nDvrLen) = FoundOk
                ArrayCntr = ArrayCntr + 1
                ReDim Preserve UserSysStringArray(1 To ArrayCntr)
                UserSysStringArray(ArrayCntr) = Left$(sServer, nSvrLen)
                sServer = Space$(DSN_LEN)
            Loop
    End If
    Call SQLFreeHandle(HANDLE_ENV, hEnv)
End If
ArrayCntr = 0
Do Until ArrayCntr = UBound(UserSysStringArray)
    ArrayCntr = ArrayCntr + 1
    Sheet1.Range("A" & ArrayCntr).Value = UserSysStringArray(ArrayCntr)
Loop
End Sub

Shortcuts for variable type declarations

$=string
&=long
%=integer

Private Declare Function SQLDataSources% Lib "ODBC32.DLL" _
   (ByVal henv&, ByVal fdir%, ByVal szDSN$, ByVal cbDSNMax%, _
   pcbDSN%, ByVal szDesc$, ByVal cbDescMax%, pcbDesc%)

is equivolent to--

Private Declare Function SQLDataSources Lib "ODBC32.DLL" _
   (ByVal henv As Long, ByVal fdir As Integer, _
   ByVal szDSN As String, ByVal cbDSNMax As Integer, _
   pcbDSN As Integer, ByVal szDesc As String, _
   ByVal cbDescMax As Integer, pcbDesc As Integer) As Integer

Damon, one of the www.mrecel.com members, posted these excellent tips that are just too good not to keep around--

1. cells do not have to be selected in order to set their 
   properties. For example, instead of: 

Range("A1").Select 
Selection.NumberFormat = "@" 

use: 

Range("A1").NumberFormat = "@" 

or just 

[A1].NumberFormat = "@" 

2. You do not have to loop through a range of cells  in order 
   to set their properties individually if you want to set 
   them all the same. For example, to set NumberFormat to 
   text for all cells in the range A1:Z10000 

[A1:Z10000].NumberFormat = "@" 

and you will find this to be much faster than setting these 
using a loop. 

This even works with disjoint ranges. Say for example that 
Table 1 is range A1:G25 and Table 2 is range J1:P25.  You 
could set the number format for both tables using 

[A1:G25,J1:P25].NumberFormat = "@" 

3. Give names to ranges that have common formatting. For 
   example, if one part of Table 1 (a) has different 
   formatting from another part of Table 1 (b), then you 
   could name the two parts of the table, for example,    Table1a and Table1b and set their formats as 

[Table1a].NumberFormat = "@" 
[Table1b].NumberFormat = "General" 

Going further, suppose Table 2 also has the same two types of formatting, and you name the two parts Table2a and Table2b. Then you could set them using 

[Table1a,Table2a].NumberFormat = "@" 
[Table1b,Table2b].NumberFormat = "General" 

which is similar to the disjoint range methodology 
mentioned in 2.

Sub FileName()
'
' FileName Macro
' Macro Created 10/3/2002 by Bryan Iams
'
Dim sdata As String
Range("IV65536").Select
ActiveCell.FormulaR1C1 = _
"=MID(CELL(""filename""),FIND(""["",CELL(""filename""))+1,FIND(""]"",CELL(""filename""))-FIND(""["",CELL(""filename""))-1)"
sdata = Selection.Value
Worksheets(1).Name = sdata 'this specifies worksheet 1
Range("IV65536").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select
End Sub

Download SheetName.xls.

Start by selecting the range of cells that you want to output then run this macro--

Sub DataDump()

'get the file name to write to
Dim FName As Variant 'must be variant type for potential boolean result
Dim defpath As String
defpath = Application.DefaultFilePath & "\" & "Formulas.txt"
FName = Application.GetSaveAsFilename(defpath, _
   "Text File (*.txt),*.txt,ASCII File (*.asc),*.asc", _
   1, "Export Formulas to Text File")

If FName = False Then
    MsgBox "You didn't enter a file name."
    Exit Sub
End If
 
'open the file for writing
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(FName, True)
Dim eol As String
eol = Chr(13) & Chr(10)
 
'write the data from the range
Dim s As String
Dim row As Integer
Dim col As Integer
row = 0
col = 0
Dim cell As Range
For Each cell In Selection.Cells
    If cell.HasFormula Then
        s = cell.Formula
        If Left(s, 1) = "=" Then
            f.write Replace(cell.Address, "$", "") & ": "
            If cell.HasArray Then
                f.write "{" & s & "}" & eol
            Else
                f.write s & eol
            End If
        End If
    Else
        s = cell.Value
        If Len(s) Then
            f.write Replace(cell.Address, "$", "") & ": "
            f.write s & eol
        End If
    End If
Next
 
'close the file and release objects
f.Close
Set fs = Nothing
 
Shell "notepad.exe " & FName, vbNormalFocus
 
End Sub

The output looks like this--

A1: y-intercept
B1: 125000
A2: slope
B2: 6
A4: y
A5: =$B$1
A6: =A5+$B$2
A7: =A6+$B$2
A8: =A7+$B$2
A9: =A8+$B$2
A10: =A9+$B$2
A11: =A10+$B$2
A12: =A11+$B$2

A spreadsheet with the example in it can be found here.

When importing zip codes into Excel, often the leading zeroes are truncated. This is because Excel thinks that they are numbers and formats them accordingly. Zip codes with dashes are seen as text and are not affected. They will have their leading zeroes present. To use this formula, insert it into a spreadsheet, select the zip codes and run it. Problem solved.

download spreadsheet with macro
If you open this spreadsheet, you can run the macro immediately against your existing workbook. It's in Tools > Macros > Macro > Run > RepairZipCodes.

Sub RepairZipCodes()
    For Each cell In Selection.Cells
        If Not cell.HasFormula Then
            If Len(cell.Value) < 5 Then
                cell.NumberFormat = "@"
                cell.Value = Right("00000" & cell.Value, 5)
            End If
        End If
    Next
End Sub