sfsteve002
Board Regular
- Joined
- Apr 10, 2011
- Messages
- 114
Hi,
Can someone help me out with this script. The script was created to breakup a spreadsheet into many spreadsheets. I'm running MAC Office 2011. Any help on this is greatly appreciated.
Can someone help me out with this script. The script was created to breakup a spreadsheet into many spreadsheets. I'm running MAC Office 2011. Any help on this is greatly appreciated.
Code:
Dim FileName As String
Dim CopyRange As String
Dim HeaderRange As String
Public Sub GenerateReport2()
Dim I As Long
Dim HIQNo As String
Dim RowIndex As Long
Dim Occurance As Long
HeaderRange = "A1:U1"
On Error GoTo ErrKiller
For I = 2 To 1048576 'Start form second row to complete excel range
HIQNo = Range("A" & I).Value
If HIQNo = "" Then Exit For
RowIndex = Application.Match(CLng(HIQNo), Excel.ActiveSheet.Columns(1), 0) 'Index of the row
Occurance = Excel.WorksheetFunction.CountIf(Range("A:A"), HIQNo) 'Total number of cell value
Occurance = RowIndex + Occurance - 1 'New point
CopyRange = "A" & RowIndex & ":U" & Occurance
FileName = Range("C" & I).Value & " - " & HIQNo & " _" & Range("B" & I).Value & " Training_Certification Reports"
I = Occurance 'Now jump to new point
'MsgBox "HIQNO:" & HIQNo & vbNewLine & CopyRange & vbNewLine & FileName
GenerateReportFile
Next
Exit Sub
ErrKiller:
MsgBox Err.Description, vbCritical
End Sub
Sub GenerateReportFile()
Dim MyXL As New Excel.Application 'Object 'Excel Application Object
Dim XL_File As String
Dim SheetName As String
Range(HeaderRange).Select
Selection.Copy
XL_File = "Macintosh HD:Users:steve:Desktop:new:" & FileName & ".xlsx"
'XL_File = "C:\Excel_Documents\" & FileName & ".xlsx"
SheetName = "Sheet1"
'Create the Excel Application Object.
'Set MyXL = CreateObject("Excel.Application")
'Create new Excel Workbook
MyXL.Workbooks.Add
'Create the Excel Workbook Object, and open existing Excel Workbook
'Set xlBook = xlApp.Workbooks.Open(XL_File)
MyXL.Worksheets(1).Name = SheetName
'Paste header row
MyXL.Worksheets(SheetName).Range("A1").Select
MyXL.Worksheets(SheetName).Paste
Range(CopyRange).Select
Selection.Copy
MyXL.Worksheets(SheetName).Range("A2").Select
MyXL.Worksheets(SheetName).Paste
'Now paste data
'Show the Excel sheet in Excel Window.
'MyXL.Application.Visible = True
'Save the Excel File
MyXL.Worksheets(1).SaveAs (XL_File)
'Close the Workbook or else XL_File will still be open and available for
'read Only!
'Or MyXL.Quit could be used instead
'MyXL.Workbooks(1).Close
'Close the Excel Window and / or Application in background
'or else XL_File will still be open and available for read Only!
MyXL.Quit
Set MyXL = Nothing
End Sub
Last edited: