Split Closed Workbook into Multiple Workbooks Using ADO

[ramakrishnan]

Dear Experts,

Is there any addin available to split the excel worsheet into multiple work books basis the input file size.

The main data is avilable in an xlsx work book having 5 lacs rows and 30 MB size. The maximum upload size possible in our internal software is 3 MB
Now i need to convert this office 2007 to office 2003 with a file sile of less than or exqual to 3 MB.

I would like to know one more thing also the office 2007 work sheet is having 2 lacs records which wil not get loaded in office 2003 is there any addin avaiable in office 2003 which will open the office 2007 file ----read it -----and copy in multiple work sheet of 65000 rows.

Thanks in advance

R.Ramakrishnan

[Excel Fox]

ramakrishnan,

it is hard to gauge the number of rows required to contribute to a certain file size, but one can do some simple calculations to decide how many rows of data would add up to make the total size.

In your case, 500000 rows add up to 30MB which means 50000 rows approximately would make up to 3MB.

There are File format converters OR Compatibility Packs (http://www.microsoft.com/download/en/details.aspx?id=3) that can convert files saved in newer versions of Office to be opened in older versions.

[ramakrishnan]

Sir,

File format convertor is already installed in my pc which is converting the xlsx to xls and open it in the office 2003 module but more than 65000 rows are not imported in the worksheet the challenge is


Split the data - when office 2007 is not installed but the file needs to be splitted in to multiple files (xls) as per the input value for no of rows. As you suggested we can ignore the size and use no of rows for splitting the xlsx file.

Is there any addin available in 2003 to do this activity.

Kindly guide.

Regards
R.Ramakrishnan

[Excel Fox]

Have you tried saving the file as csv?

[Admin]

Hi Ramakrishnan,

Try this. Thanks to Ron Debruin

In a standard module


Public rsCon As Object
Public rsData As Object

Dim arrFields() As String
Dim blnFieldStored As Boolean

Public Sub GetData(SourceFile As Variant, SourceSheet As String, SourceRange As String, _
Header As Boolean, UseHeaderRow As Boolean, Fname As String)

'Original code: Ron Debruin
' 30-Dec-2007, working in Excel 2000-2007
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
Dim wbkActive As Workbook
Dim wbkNew As Workbook

Set wbkActive = ThisWorkbook

' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If

If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If

On Error GoTo SomethingWrong

If rsCon Is Nothing Then
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
End If

If Not rsCon.State = 1 Then rsCon.Open szConnect

If rsData.State = 1 Then rsData.Close
rsData.Open szSQL, rsCon, 0, 1, 1

' Check to make sure we received data and copy the data
If Not rsData.EOF Then
Set wbkNew = Workbooks.Add
If Not blnFieldStored Then
For i = 1 To rsData.Fields.Count
ReDim Preserve arrFields(1 To i)
arrFields(i) = rsData.Fields(i - 1).Name
Next
blnFieldStored = True
End If

'Add the header cell in each column if the last argument is True
With wbkNew.Worksheets(1)
.Cells(1, 1).Resize(, UBound(arrFields)) = arrFields
.Cells(2, 1).CopyFromRecordset rsData
End With

wbkNew.SaveAs ThisWorkbook.Path & "\" & Fname, 51
wbkNew.Close
Set wbkNew = Nothing
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If

' Clean up
Set wbkActive = Nothing
Exit Sub

SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0

End Sub

Again in a standard module. (Better in a new module)


Sub kTest()

Dim i As Long
Dim Fname As String
Dim n As Long

Const NewWbkRows As Long = 40000 '<<==== adjust this rows
Const TotalRows As Long = 300000 '<<==== adjust this rows

Const SourceFile As String = "D:\Temp\Sample.xlsx" '<<==== adjust to suit


For i = 1 To TotalRows Step NewWbkRows
n = n + 1
If i = 1 Then
GetData SourceFile, "Sheet1", _
"A" & i & ":H" & i + NewWbkRows - 1, True, True, "NewFile" & n
Else
GetData SourceFile, "Sheet1", _
"A" & i & ":H" & i + NewWbkRows - 1, True, False, "NewFile" & n
End If
Next

If rsData.State = 1 Then rsData.Close
Set rsData = Nothing
If rsCon.State = 1 Then rsCon.Close
Set rsCon = Nothing

End Sub

Adjust the rows and file path.