Split Data into Multiple Sheets based on Column (45K rows of Data, Overflow error HELP)

[apurcell]

Hi everyone. First time posting. The problem is exactly as described. I am new to MACROS and VBA.
This is the code I am using (Thank you to the individual who posted it) Split data into multiple worksheet based on column variables - edited from online sources
on the line i = 2 to lr, it is giving me a yellow arrow. and says Overflow error

I imagine because I have 45K rows of data.

I like this MACRO because it lets you pick which column you want to split on. I have different data sets of different lengths and we need to split on different columns for each on.

I appreciate any help in advance.

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub

 

[dmt32]

Hi,
welcome to forum

have a look here:Search though 10,000 lines to split across various tabs

Post #3 is solution I provided for a similar requirement - see if it will help you

Dave

 

[gtwo]

Hey there.

That error is because i was declared as integer, and integers are number from –32768 to +32768, so as you have more than 32768 itens, you are receiving that message.

To fix that change the line:
Dim vcol, i As Integer
to
Dim vcol, i As Long

Long is number variable from -2,147,483,648 to 2,147,483,647.

Good luck

 

[apurcell]

Thank you to the both of you. @gtwo your solution worked!! Life saver.

Maybe I am trying my luck, but I figure I will ask, is there any way to add to this MACRO so that on each sheet it SUBTOTALS by each change in a Column and performs the Subtotal (SUM) on a different column?

Thanks for your help

 

[gtwo]

It is totally possible to do that, but it would help a lot if I could see how is your data, otherwise I have to imagine too much

 

[apurcell]

ACCOUNT #

DOC.TYP

DOC.NBR

DOC.DATE

TRANS DATE

ITEM #

ITEM DESCRIPTION

VENDOR NAME

ITEM AMOUNT

DEPARTMENT

MID

DEPT

In one of the data sets, it is set up like this. There are thousands of transactions, by ACCOUNT # (column A). The number I would like to sum is ITEM AMOUNT (column I) based on changes in the Account # (Column A)

In the other data set it is set up like this. The goal is the same, the number I would like to sum is AMOUNT (column H) based on changes in the Account Description (Column E).

Journal Entry

Series

TRX Date

Account Number

Account Description

Debit Amt

Credit Amt

Amount

Description

Reference

Vendor

MID

DEPT

You see how in the original MACRO I posted how it asks which column number you want to split the sheets into? This works well for me as it allows me to apply the MACRO to both data sets as I am splitting on the DEPT column.

It would be helpful if adding this subtotal request to the original MACRO it would ask: What column would you like to SUM? and then ask: On changes in which column number?

The data is cleaned and sorted by account number Ascending before we load it into the sheet and run the MACRO on it so it comes out of the MACRO sorted in its own sheet.

Any help is very much appreciated Please let me know if I can clarify any further.

 

[dmt32]

It would be helpful if adding this subtotal request to the original MACRO it would ask: What column would you like to SUM?

Hi,
See if this update to code I created for another here in past does what you want

Option Explicit
Sub FilterData()
'DMT32
    Dim ws1Master As Worksheet, wsFilterToSheet As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange(1 To 2) As Range, rng As Range
    Dim rowcount As Long, FilterRow As Long
    Dim colcount As Integer, FilterCol As Integer, i As Integer
    Dim SheetName As String, msg As String, Prompt As String
   
   
'master sheet
    Set ws1Master = ActiveSheet
   
'InputBox Prompts
' 1 - Column you are filtering
' 2 - Column you want to Total
top:
    i = 1
    Do
    Prompt = Choose(i, "Select Field Name To Filter", "Select Field Name To Sum")
    On Error Resume Next
    Set objRange(i) = Application.InputBox(Prompt, "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange(i) Is Nothing Then Exit Sub
    If objRange(i).Columns.Count = 1 Then i = i + 1
    Loop Until i > 2
   
    FilterCol = objRange(1).Column
    FilterRow = objRange(1).Row
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
   
    On Error GoTo progend
   
'add filter sheet
    Set wsFilter = Sheets.Add
   
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
       
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
       
        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If
       
        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
       
'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
       
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
       
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
       
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
           
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
               
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'ensure tab name limit not exceeded
                SheetName = Trim(Left(FilterRange.Value, 31))
'check if Filter sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
                    Set wsFilterToSheet = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsFilterToSheet.Name = SheetName
                Else
                    Set wsFilterToSheet = Worksheets(SheetName)
'clear existing data
                    wsFilterToSheet.UsedRange.Clear
                End If
               
'add / update
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsFilterToSheet.Range("A1"), Unique:=False
            End If
           
            Set rng = wsFilterToSheet.UsedRange
             With rng.Cells(rng.Rows.Count + 1, objRange(2).Column)
                .Value = Application.Sum(rng.Columns(objRange(2).Column))
                .Font.Bold = True
             End With
            
            wsFilterToSheet.UsedRange.Columns.AutoFit
           
            Set wsFilterToSheet = Nothing
            Set rng = Nothing
        Next
       
        .Select
    End With
   
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

Dave

 

[apurcell]

Hi,
See if this update to code I created for another here in past does what you want

Option Explicit
Sub FilterData()
'DMT32
    Dim ws1Master As Worksheet, wsFilterToSheet As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange(1 To 2) As Range, rng As Range
    Dim rowcount As Long, FilterRow As Long
    Dim colcount As Integer, FilterCol As Integer, i As Integer
    Dim SheetName As String, msg As String, Prompt As String
  
  
'master sheet
    Set ws1Master = ActiveSheet
  
'InputBox Prompts
' 1 - Column you are filtering
' 2 - Column you want to Total
top:
    i = 1
    Do
    Prompt = Choose(i, "Select Field Name To Filter", "Select Field Name To Sum")
    On Error Resume Next
    Set objRange(i) = Application.InputBox(Prompt, "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange(i) Is Nothing Then Exit Sub
    If objRange(i).Columns.Count = 1 Then i = i + 1
    Loop Until i > 2
  
    FilterCol = objRange(1).Column
    FilterRow = objRange(1).Row
  
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
  
    On Error GoTo progend
  
'add filter sheet
    Set wsFilter = Sheets.Add
  
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
      
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
      
        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If
      
        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
      
'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
      
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
      
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
      
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
          
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
              
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'ensure tab name limit not exceeded
                SheetName = Trim(Left(FilterRange.Value, 31))
'check if Filter sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
                    Set wsFilterToSheet = Sheets.Add(after:=Worksheets(Worksheets.Count))
                    wsFilterToSheet.Name = SheetName
                Else
                    Set wsFilterToSheet = Worksheets(SheetName)
'clear existing data
                    wsFilterToSheet.UsedRange.Clear
                End If
              
'add / update
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsFilterToSheet.Range("A1"), Unique:=False
            End If
          
            Set rng = wsFilterToSheet.UsedRange
             With rng.Cells(rng.Rows.Count + 1, objRange(2).Column)
                .Value = Application.Sum(rng.Columns(objRange(2).Column))
                .Font.Bold = True
             End With
           
            wsFilterToSheet.UsedRange.Columns.AutoFit
          
            Set wsFilterToSheet = Nothing
            Set rng = Nothing
        Next
      
        .Select
    End With
  
progend:
    wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

Dave

Hi @dmt32, where would I add this to the code?

 

[dmt32]

Hi @dmt32, where would I add this to the code?

I my code goes in a standard module & REPLACES any existing code you may be using
I included an edit to ask which column you want to sum when the sheets data is split.

Dave

 

[apurcell]

I my code goes in a standard module & REPLACES any existing code you may be using
I included an edit to ask which column you want to sum when the sheets data is split.

Dave

Hi @dmt32 and @gtwo
Im sorry I probably didnt make it clear in my request. We work with two seperate data sets. On one of them, I need to Sum Column 8 after each change in column 1 and the other data set: I need to sum Column 9 on each change in column 5. I was hoping for a way where it would ask me to type in which row I would like to sum. but if not that would still be very useful and I could just change the code for each one.