Extract Records to New Workbook

[dgr]

Hello,
I'm using Excel 2013. I'm looking for a VB macro.

I've got a workbook which has got more than a million records. Therefore, this workbook has become very sluggish & difficult to handle. I now want to extract every 100,000 records to a new workbook so that I can manage the data well & eventually export it to Ms Access at a later stage. Therefore, I will be having 10 small workbooks to manage instead of having 1 huge workbook.

Could you show me a macro which can extract every 100,000 records to a new workbook please?

Thanks. I appreciate your help.

 

[skorpionkz]

Assuming that first row have headers, try this code:


EDIT:

Sub MultDB()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WB As Workbook, WBCurr As Workbook
Dim WS As Worksheet, WSCurr As Worksheet
Dim irow As Integer, i As Integer, icounter As Integer
Set WBCurr = ActiveWorkbook
Set WSCurr = WBCurr.ActiveSheet
irow = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
icounter = 0
    For i = irow To 2 Step -100001
        If i > 100002 Then
            Set WB = Workbooks.Add
                With WB
                    icounter = icounter + 1
                    .SaveAs Filename:="Part" & icounter & ".xls"
                End With
                Set WS = WB.Sheets.Add
                WS.Name = "Part" & icounter

            Set WS = WB.ActiveSheet
            
            WS.Range("1:1").Value = WSCurr.Range("1:1").Value
            WS.Range("2:100002").Value = WSCurr.Range(i - 100000 & ":" & i).Value
        Else
            Set WB = Workbooks.Add
                With WB
                    icounter = icounter + 1
                    .SaveAs Filename:="Part" & icounter & ".xls"
                End With
                Set WS = WB.Sheets.Add
                WS.Name = "Part" & icounter

            Set WS = WB.ActiveSheet
            
            WS.Range("1:" & i).Value = WSCurr.Range("1:" & i).Value
            
        End If
    Next i
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[dgr]

Thanks for your help skorpionkz.

I get a runtime error 6 (overflow) and the following line is yellow:

irow = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

 

[skorpionkz]

sorry, my mistake. try this correction
EDIT:

sorry need to check again, as it comes with Out of Memory error

 

[dgr]

Sorry to trouble you again.

Now I get a runtime error 7 (out of memory) and the following line is yellow:

WS.Range("2:100002").Value = WSCurr.Range(i - 100000 & ":" & i).Value

This particular workbook that I'm working on has got 384,000+ records (just for your info).

Thank you once again Andrzej .

 

[skorpionkz]

Try this fix:

Sub MultDB()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WB As Workbook, WBCurr As Workbook
Dim WS As Worksheet, WSCurr As Worksheet
Dim icounter As Integer
Dim drow As Double, dcol As Double, i As Double
Dim strcheck As String
Set WBCurr = ActiveWorkbook
Set WSCurr = WBCurr.ActiveSheet
drow = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
dcol = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
icounter = 0
    For i = drow To 2 Step -99999
        If i > 100000 Then
            Set WB = Workbooks.Add
                With WB
                    icounter = icounter + 1
                    .SaveAs Filename:="Part" & icounter & ".xls"
                End With
                Set WS = WB.Sheets.Add
                WS.Name = "Part" & icounter
            Set WS = WB.ActiveSheet
            
            WS.Range("1:1").Value = WSCurr.Range("1:1").Value
            WSCurr.Activate
            Range(Cells(i - 99999, 1), Cells(i, dcol)).Copy
                        
            WS.Activate
            Cells(2, 1).PasteSpecial xlValue
        Else
            Set WB = Workbooks.Add
                With WB
                    icounter = icounter + 1
                    .SaveAs Filename:="Part" & icounter & ".xls"
                End With
                Set WS = WB.Sheets.Add
                WS.Name = "Part" & icounter
            Set WS = WB.ActiveSheet
            
            WSCurr.Activate
            Range(Cells(1, 1), Cells(i, dcol)).Copy
                        
            WS.Activate
            Cells(1, 1).PasteSpecial xlValue
            
        End If
    Next i
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[dgr]

Well, the code did the job but not in an elegant way, I must say. For example, the 1st record of part1.xls also appeared as the last record in part2.xls. The macro ran for 30 minutes on a workbook of 384,000+ records. Suspecting that something was not right, I hit the Esc button to stop it. To my surprise, part1.xls - part4.xls appeared. After having hit the Save button for part1.xls - part4.xls, now I can't find it on my hard drive. Oh dear.

Andrzej , thank you once again for trying to help me.

 

[skorpionkz]

It seems that something went wrong there.


Try this correction:

Sub MultDB()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WB As Workbook, WBCurr As Workbook
Dim WS As Worksheet, WSCurr As Worksheet
Dim icounter As Integer
Dim drow As Double, dcol As Double, i As Double
Dim strcheck As String
Set WBCurr = ActiveWorkbook
Set WSCurr = WBCurr.ActiveSheet
drow = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
dcol = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
icounter = 0
    For i = drow To 2 Step -100000
        If i > 100000 Then
            Set WB = Workbooks.Add
                With WB
                    icounter = icounter + 1
                    .SaveAs Filename:="Part" & icounter & ".xls"
                End With
                Set WS = WB.Sheets.Add
                WS.Name = "Part" & icounter
            Set WS = WB.ActiveSheet
            
            WS.Range("1:1").Value = WSCurr.Range("1:1").Value
            WSCurr.Activate
            Range(Cells(i - 99999, 1), Cells(i, dcol)).Copy
                        
            WS.Activate
            Cells(2, 1).PasteSpecial xlValue
        Else
            Set WB = Workbooks.Add
                With WB
                    icounter = icounter + 1
                    .SaveAs Filename:="Part" & icounter & ".xls"
                End With
                Set WS = WB.Sheets.Add
                WS.Name = "Part" & icounter
            Set WS = WB.ActiveSheet
            
            WSCurr.Activate
            Range(Cells(1, 1), Cells(i, dcol)).Copy
                        
            WS.Activate
            Cells(1, 1).PasteSpecial xlValue
            Exit For
        End If
    Next i
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[dgr]

Excellent work, Andrew. It worked well this time. I truly appreciate your effort. Have a good day.