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 FromSheet As Worksheet
Dim NumColumns As Integer
Dim fromRow As Long
Dim ToBook As String
Dim ToSheet As Worksheet
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 = FromSheet.Range("A1").End(xlToRight).Column
fromRow = FromSheet.Range("A65536").End(xlUp).Row
For RowIndex = 1 To fromRow
Workbooks(FromBook).Activate
FromSheet.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 = ToSheet.Range("A65536").End(xlUp).Row
'- copy paste
FromSheet.Range(Cells(fromRow, 1), Cells(fromRow,
NumColumns)).Copy _
Destination:=ToSheet.Range("A" & LastRow + 1)
FromSheet.Range(Cells(fromRow, 1), Cells(fromRow,
NumColumns)).EntireRow.Interior.Color = vbMagenta
rowsOUt = rowsOUt + 1
'- set next FromRow
fromRow = FromSheet.Range("A65536").End(xlUp).Row + 1
End Sub
