Split Large File

[Camconfused]

I have a large excel file (250k+lines), each has a Customer no and a Level (high, med, low) and I need to split into 30 equal files (that's now the problem).
My question is can this be done taking the same amount of high, med, low for each group. I dont want some groups to have all the high and some all the low, I really want them to be equally distributed but I cant think in my brain how I would do this?

 

[ranman256]

this code assumes:
there is a unique key value in col.A (ID)
level value is in col.M (sLevel)
#groups: iGrpCt = 30

it then reads every record and puts them in a collection : hi, med, or Low
then cycles thru all collections evenly to distribute into iGrpCt workbooks

run: SplitUpData

Private vID As String
Private wbSrc As Workbook, wbTarg As Workbook
Public giRowCt As Integer, giRecsPerGrp As Integer

Sub SplitUpData()
Dim iRecs As Long, iGrpCt As Integer, g As Integer
Dim colHi As New Collection, colMed As New Collection, colLow As New Collection
Dim sLevel As String
Dim vDir, vFileName

vDir = getMyDocs()
Set wbSrc = ActiveWorkbook
Range("A1").Select
iRecs = ActiveSheet.UsedRange.Rows.Count - 1    'ignore header
'iRecs = 250000

iGrpCt = 30
giRecsPerGrp = iRecs / iGrpCt

'is there an Key rec (unique ID) ?

'3 collections:  high , med, low
'Set colHi = New Collection
'Set colMed = New Collection
'Set colLow = New Collection

  'scan all recs , put keys into their buckets
While ActiveCell.Value <> ""
   vID = ActiveCell.Offset(0, 0).Value      'key valu
   sLevel = ActiveCell.Offset(0, 12).Value  'level value

Select Case LCase(sLevel)
   Case "high"
      colHi.Add vID, vID
   Case "med"
      colMed.Add vID, vID
   Case "low"
      colLow.Add vID, vID
End Select

   NextRow
Wend


  'now create Grp files
For g = 1 To iGrpCt
    giRowCt = 1
      'new target file
    Workbooks.Add
    Set wbTarg = ActiveWorkbook
   
      'post header
    wbSrc.Activate
    Rows("1:1").Copy
    wbTarg.Activate
    PasteCells
    wbSrc.Activate
   
       'post N records
    While giRowCt <= giRecsPerGrp
       getNextColRec colHi
       getNextColRec colMed
       getNextColRec colLow
    Wend
   
    vFileName = vDir & "Grp" & g & ".xlsx"
    wbTarg.Close True, vFileName
    wbSrc.Activate
Next

MsgBox "Done"

Set colHi = Nothing
Set colMed = Nothing
Set colLow = Nothing
Set wbSrc = Nothing
Set wbTarg = Nothing
End Sub


Private Sub findKey(pvID)
On Error GoTo ErrFind
    Range("A1").Select
    Cells.Find(What:=pvID, After:=ActiveCell, LookIn:=xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Exit Sub
ErrFind:
pvID = 0
End Sub

Public Sub getNextColRec(pcol As Collection)
Dim r As Long

If giRowCt > giRecsPerGrp Then Exit Sub
 
wbSrc.Activate

If pcol.Count > 0 Then
    vID = pcol(1)  'get index key from list
    findKey vID     'find key record
      'copy rec
    If vID <> 0 Then
      r = ActiveCell.Row
      Rows(r & ":" & r).Copy
     
          wbTarg.Activate
          NextRow
          PasteCells
          wbSrc.Activate
       
        giRowCt = giRowCt + 1
           'remove source rec
        pcol.Remove vID
    End If
End If
End Sub

Private Sub NextRow()
  ActiveCell.Offset(1, 0).Select 'next row
End Sub

Private Function getMyDocs()
getMyDocs = Environ$("USERPROFILE") & "\Documents\"
End Function

Private Sub PasteCells()
          ActiveSheet.Paste
          Application.CutCopyMode = False
End Sub