Hi All

I would like some tips on some VBA code:

I need to send 80 emails each with an individual excel attachment.

I have 1 source document, Column A depicts the email B:S contains the data.

How can I easily extract the source sheet to create 80 separate XLS documents?

I currently create the 80 documents manually (Cut & Paste) but I really would like some code that would do it for me.

I've been working with the following code which tries to do something but it never seems to work, would anyone be able to assist?

Code:

Sub Split_Report_By_Column()
SplitByColumn ActiveWorkbook.Path, ActiveWorkbook.Name, ActiveWorkbook.ActiveSheet, 1, False
End Sub

Sub SplitByColumn(wsPath, wsName, wsData As Worksheet, intCol As Integer, Optional blnDeleteBlankSourceRows As Boolean = False)
Dim rangeHeaders As Range
Dim rangeTarget As Range
Dim strWorkBookExtension As String
Dim strWorkbookName As String
Dim varWorkBook As Variant
Dim wbTarget As Workbook
Dim arrNewWorkbooks() As Workbook
'Dim iSheetCount As Integer

strTitle = Left(wsName, Len(wsName) - 5)
strWorkBookExtension = ".xls"

ReDim arrNewWorkbooks(0)
Set rangeHeaders = wsData.Range(wsData.Range("A1"), wsData.Range("A1").End(xlToRight))
intMaxRow = rangeHeaders.SpecialCells(xlCellTypeLastCell).Row
i = 1
While i <= intMaxRow
strWorkbookName = Trim(wsData.Range("A1").Offset(i).Value)
If strWorkbookName <> "" Then
strWorkbookName = strWorkbookName & strWorkBookExtension
On Error Resume Next
Set wbTarget = Workbooks(strWorkbookName)
If Err.Number <> 0 Then
Err.Clear
Set wbTarget = Workbooks.Open(wsPath & "\" & strWorkbookName)
If Err.Number <> 0 Then
Err.Clear
Set wbTarget = Workbooks.Add
wbTarget.Sheets(1).Range("A1").Value = strTitle
Set rangeHeaderTarget = wbTarget.Sheets(1).Cells(wbTarget.Sheets(1).Range("A1").SpecialCells(xlCellTypeLastCell).Row + 2, 1)
rangeHeaders.Copy Destination:=rangeHeaderTarget
wbTarget.SaveAs wsPath & "\" & strWorkbookName, FileFormat:=56
Else
If strWorkbookName <> strLastValue Then
wbTarget.Sheets(1).Unprotect
wbTarget.Sheets(1).Range("A1").Offset(wbTarget.Sheets(1).UsedRange.Rows.Count + 1, 0).Value = strTitle
Set rangeHeaderTarget = wbTarget.Sheets(1).Cells(wbTarget.Sheets(1).Range("A1").SpecialCells(xlCellTypeLastCell).Row + 2, 1)
rangeHeaders.Copy Destination:=rangeHeaderTarget
End If
End If
wbTarget.Sheets(1).Unprotect
strLastValue = strWorkbookName
ReDim Preserve arrNewWorkbooks(UBound(arrNewWorkbooks) + 1)
Set arrNewWorkbooks(UBound(arrNewWorkbooks)) = wbTarget
End If
On Error GoTo 0
wbTarget.Sheets(1).Unprotect
Set rangeTarget = wbTarget.Sheets(1).Cells(wbTarget.Sheets(1).Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1, 1)
rangeHeaders.Offset(i).Copy Destination:=rangeTarget
Else
If blnDeleteBlankSourceRows Then wsData.Rows(i + rangeHeaders.Row).Delete
End If
i = i + 1
Wend

For Each varWorkBook In arrNewWorkbooks
If Not varWorkBook Is Nothing Then
WordWrap varWorkBook

varWorkBook.Save
varWorkBook.Close
End If
Next
End Sub

Public Sub WordWrap(wbTarget)
wbTarget.Activate
wbTarget.Sheets(1).Unprotect
varColumnsCount = wbTarget.Worksheets(1).UsedRange.Columns.Count
wbTarget.Sheets(1).Columns.AutoFit
wbTarget.Sheets(1).Cells.WrapText = True


For Each c In wbTarget.Sheets(1).Range(Cells(1, 1), Cells(1, varColumnsCount)).Columns
If c.ColumnWidth > 15 Then
c.ColumnWidth = 15
End If
Next c

wbTarget.Worksheets(1).Rows.AutoFit
End Sub