Need to split XLS file based on value of field

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

From: jeff (anonymous_at_discussions.microsoft.com)
Date: 07/06/04 

Date: Tue, 6 Jul 2004 11:27:50 -0700

Hi,

Try this set of macros. First, create a folder and put
only your main data file in it. Paste the macros in and
edit the "DIM" line with the "ValueNames" variable to
the total # of separate files you'll have,
add both the value to select and its corresponding
filename for each variable set in "ValueNames). Change
the value of LastValue to the total number of ValueNames
(from 3);
finally, modify "Selection.Offset(0, 2).Value" line -
change the 2 in .Offset to the number of columns to the
right of A that your selector value is in. (2=C; if in
col A, then zero);

This code will create a new file for each new value
in your data in the same directory and add to them.
Transferred rows will be colored magenta in master file.

Good luck
jeff

Dim FromBook As String
Dim From*** As Work***
Dim NumColumns As Integer
Dim fromRow As Long
Dim ToBook As String
Dim To*** As Work***
Dim ToRow As Long
Dim LastRow As Long
Dim CurRow As Long
Dim RowIndex As Long
Dim R As Range
Dim rowsIn, rowsOUt As Long
Dim ValueName(10, 1) As String ' Adjust 10 to # files

Sub CopyOut()
'ValueName - 0 element is value to find, 1 is name of file
ValueName(1, 0) = "3" ' this the search value
ValueName(1, 1) = "File3" ' this is 3's file name
ValueName(2, 0) = "JR" ' etc..
ValueName(2, 1) = "FileJR"
ValueName(3, 0) = "Master"
ValueName(3, 1) = "FileMaster"
LastValue = 3 ' this is the number of selections needed
from ValueName array

Application.Calculation = xlCalculationManual
ChDrive ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
FromBook = ActiveWorkbook.Name
Set FromSheet = ActiveWorkbook.Worksheets(1)
NumColumns = From***.Range("A1").End(xlToRight).Column
fromRow = From***.Range("A65536").End(xlUp).Row

For RowIndex = 1 To fromRow
    Workbooks(FromBook).Activate
    From***.Range("A" & RowIndex & ":A" &
RowIndex).Select
    rowsIn = rowsIn + 1
    For CurRow = 1 To LastValue
        If Selection.Offset(0, 2).Value = ValueName
(CurRow, 0) Then
            fromRow = RowIndex
            Transfer_data CurRow
            Exit For
        End If
    Next CurRow
Next RowIndex

'-- close
For j = Workbooks.Count To 2 Step -1
Workbooks(j).Close savechanges:=True
Next j

MsgBox ("Run Finished. " & rowsIn & " Rows In; " &
rowsOUt & " Rows Out.")
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
End Sub

Sub Transfer_data(j As Long)
Dim IsOpen As Boolean
ToBook = ValueName(j, 1)
ToBookfile = ValueName(j, 1) & ".xls"
IsOpen = False
For k = 1 To Workbooks.Count
If ToBookfile = Workbooks(k).Name Then
    IsOpen = True
    Workbooks(ToBookfile).Activate
    Exit For
End If
Next k
If IsOpen = False Then
    Workbooks.Add
    On Error Resume Next
    ActiveWorkbook.SaveAs ToBook
End If

Set ToSheet = ActiveWorkbook.Worksheets("Sheet1")
LastRow = To***.Range("A65536").End(xlUp).Row
'- copy paste
From***.Range(Cells(fromRow, 1), Cells(fromRow,
NumColumns)).Copy _
    Destination:=To***.Range("A" & LastRow + 1)
From***.Range(Cells(fromRow, 1), Cells(fromRow,
NumColumns)).EntireRow.Interior.Color = vbMagenta
rowsOUt = rowsOUt + 1
'- set next FromRow
fromRow = From***.Range("A65536").End(xlUp).Row + 1

End Sub

>-----Original Message-----
>I have an XLS file with several thousand records.
>
>Several of the fields use a restricted drop-down list
for entering data
>- the choices on the drop-down list being pulled
from "hidden"
>worksheets. I say this because I think this means that
the file has to
>remain XLS and not CSV or that restricted trop-down
won't work.
>
>I now need to split this file into about a 100 files,
based on the
>value in one of the columns.
>
>Is there a simple way to do this??
>
>
>---
>Message posted from http://www.ExcelForum.com/
>
>.
>

Quantcast