Hello Jpcp,
The macro listed at the end of the answer should handle the problem
you have set. The first part of the answer will explain the two
subroutines and how they work.
The subroutine named FileMaker takes two parameters
- the header to be pasted at the top
- the name of the file to be written to (with added .XLS)
and it assumes that the current selection is the data to be output.
FileMaker copies the data, creates the new worksheet, pastes the
header and then the data, writes the file, and then closes the
worksheet. This is a helper function, called twice from the main
function. You may also get prompted Yes / No to overwrite the files if
you don't clean up the directory between each macro run. That can be a
helpful debug indication - you can see the selected range in the
background while the prompt is shown.
The main function ExtractData assumes you have selected at least one
cell in the "Current Region" of data to be processed. It will do the
rest once started. It also assumes the data to be processed is in a
single region but may have more / less rows or columns.
ExtractData first declares two objects
- MyRange is used for the range of data to be operated on
- Header will get the first row of data
The first few lines determine the size of the current region and
initializes other variables.
A key variable named "FileCol" can be changed if the column of data to
be used for the name of the file needs to be changed. Note - in your
sample data, you have the same Acct for "Columbia U" and "Colombia U"
(a slight misspelling) - hence the macro as written will generate two
files for this Acct. If you change the value of MatchCol to 1, it will
match on Acct instead of AcctName and then the account number will be
used to determine the change and only one file will be generated for
this Acct, having all three lines. Make this change if you need it.
The "For Each" loop goes through each row. The first row is remembered
as Header. The second time through, S$ is initialized with the first
value to match. On all subsequent rows, if the match value changes,
the range of values will be selected and FileMaker is called. The loop
also keeps track of the "current row" and "selection row" ( the one
with the first matching value).
After the last row is processed, the last range of matching values are
selected and FileMaker is called one last time to complete the file
output.
If you have any problems at all, do not hesitate to use a
clarification request to get further information on how to use,
modify, or better understand this set of macros.
Good luck with your work.
--Maniac
Note - as a result of formatting, it may be necessary to paste a
couple lines back together. I have tried to keep the line length below
70 to reduce that possibility (the few continued lines) but keep that
in mind if it does not run right the first time.
Also, if you have not used macros before - use the menu
Tools -> Macro -> Visual Basic Editor
In Visual Basic, use
Insert -> Module
to bring up a window an paste the remaining part of this answer into
that window. Go back to Excel using
View -> Microsoft Excel
You should now be able to use
Tools -> Macro
select the macro Extract_Data and then Run to generate the files. Be
sure to save the macro with your data or if interested, I can describe
how to add it to a separate file (or your default file) so the macro
is available if you need to run it with more than one data
spreadsheet.
--- The macro is below this line ---
Sub FileMaker(Header, S$)
'
' FileMaker Macro
' Macro written 12/3/2003 by Maniac
' Assume current selection is the region to be written into the
' file named S$.xls. The header is pasted above the data values.
'
'
Selection.Copy
Workbooks.Add
HeaderCols = Header.Columns.Count
With ActiveSheet
.Range(.Cells(1, 1), .Cells(1, HeaderCols)).Value = Header.Value
.Cells(2, 1).Select
.Paste
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveAs FileName:=S$ + ".xls"
ActiveWindow.Close
End Sub
Sub ExtractData()
'
' ExtractData Macro
' Macro written 12/3/2003 by Maniac
' Assume current selection is with the region of data to be
' saved into files, each file named based on the value in the
' second column (NameCol)
'
' Extract the information on the region to process
Dim MyRange As Object
Dim Header As Object
Set MyRange = Selection.CurrentRegion
With MyRange
FirstCol = .Column
LastCol = .Columns(.Columns.Count).Column - FirstCol + 1
FirstRow = .Row
LastRow = .Rows(.Rows.Count).Row - FirstRow + 1
End With
M$ = "" ' Default to no match name
F$ = "" ' Default to no file name
CurRow = 1
SelRow = 1
' Adjust following lines and/or comment to adjust macro operation
FileCol = 2
MatchCol = 2
' Main loop, go through each row to end of range
For Each r In MyRange.Rows
If M$ <> r.Cells(1, MatchCol) Then
If M$ <> "" Then
MyRange.Range(MyRange.Cells(SelRow, 1), _
MyRange.Cells(CurRow - 1, LastCol)).Select
Call FileMaker(Header, F$)
SelRow = CurRow
M$ = r.Cells(1, MatchCol)
F$ = r.Cells(1, FileCol)
Else
If CurRow = 1 Then
Set Header = r
Else
M$ = r.Cells(1, MatchCol)
F$ = r.Cells(1, FileCol)
SelRow = CurRow
End If
End If
Else
' Do nothing if in middle of range of cells
End If
CurRow = CurRow + 1
Next r
' Don't forget the last region of values
MyRange.Range(MyRange.Cells(SelRow, 1), _
MyRange.Cells(CurRow - 1, LastCol)).Select
Call FileMaker(Header, F$)
End Sub |
,
0 Comments
)