Extract Records to New Workbook

dgr

Board Regular
Joined
Apr 24, 2005
Messages
176
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.
 

Some videos you may like

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

skorpionkz

Well-known Member
Joined
Oct 1, 2013
Messages
1,166
Assuming that first row have headers, try this code:


EDIT:
Code:
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
 
Last edited:

dgr

Board Regular
Joined
Apr 24, 2005
Messages
176
Thanks for your help skorpionkz.

I get a runtime error 6 (overflow) and the following line is yellow:
Code:
irow = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
 

skorpionkz

Well-known Member
Joined
Oct 1, 2013
Messages
1,166
sorry, my mistake. try this correction
EDIT:

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

dgr

Board Regular
Joined
Apr 24, 2005
Messages
176

ADVERTISEMENT

Sorry to trouble you again.

Now I get a runtime error 7 (out of memory) and the following line is yellow:
Code:
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

Well-known Member
Joined
Oct 1, 2013
Messages
1,166
Try this fix:

Code:
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

Board Regular
Joined
Apr 24, 2005
Messages
176

ADVERTISEMENT

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.
 
Last edited:

skorpionkz

Well-known Member
Joined
Oct 1, 2013
Messages
1,166
It seems that something went wrong there.


Try this correction:
Code:
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
 
Last edited:

dgr

Board Regular
Joined
Apr 24, 2005
Messages
176
Excellent work, Andrew. It worked well this time. I truly appreciate your effort. Have a good day.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,518
Messages
5,529,311
Members
409,862
Latest member
lbisacca
Top