Split Closed Workbook into Multiple Workbooks Using ADO

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

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.

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

Have you tried saving the file as csv?

Hi Ramakrishnan,

Try this. Thanks to Ron Debruin

In a standard module

Code:

---

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)

Code:

---

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.