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 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.