How to merge multiple rows of data to new formated sheets
 

PROBLEM:

I have a single RC sheet of project data in an Excel workbook.

I need to automatically merge each rows of data from select columns of the
Main_Sheet to specific cell locations in a NewSheet. (Basically the equivlent
of a Merge in Word)

There are approx. 150 records (rows) and ultimately, each should be in its
own sheet, all with a common format different than the MainSheet.

The NewSheet will later be extracted to seperate Excel files.

I have found macros that convert the row data to seperate sheets.
I also have found a macro that will convert the seperate sheets into
seperate Excel files.

However, I am unable to find a way for the NewSheet to use a template or
automatically format as needed.

I am also unable to determine how to have the MainSheet row/column data
populate the specific cell location. (i.e. Row data in MainSheet Column B
should poplulate the NewSheet in Row 5, Row 5 Column D).

I'm wondering if using a form will help, but the cell mapping still escapes
me?

SAMPLE SHEET TO FILE MACRO per author Rob Bovey is:

Sub Copy_All_Sheets_To_New_Workbook()
Dim FName As Variant
Dim WbMain As Workbook
Dim Wb As Workbook
Dim sh As Worksheet
Dim MyPath As String
Dim SaveDriveDir As String
Dim DateString As String
Dim FolderName As String

SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'Or use a path like this "C:\Data"
ChDrive MyPath
ChDir MyPath

FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls),
*.xls")
If FName < False Then
If bIsBookOpen(Dir(FName)) Then
MsgBox "The file is already open"
Else
Application.ScreenUpdating = False
DateString = Format(Now, "yy-mm-dd hh-mm-ss")
Set WbMain = Workbooks.Open(FName)
MkDir WbMain.Path & "\" & WbMain.Name & " " & DateString
FolderName = WbMain.Path & "\" & WbMain.Name & " " & DateString

For Each sh In WbMain.Worksheets
If sh.Visible = -1 Then
sh.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs FolderName _
& "\" & Wb.Sheets(1).Name & ".xls"
Wb.Close False
Set Wb = Nothing
End If
Next sh
MsgBox "Look in " & FolderName & " for the files"
WbMain.Close False
Application.ScreenUpdating = True
End If
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub

Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


SAMPLE ROWS TO SHEET MACRO per Debra Dalgleish, Contextures

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet.1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("C:C").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row

'set up Criteria Area
Range("L1").Value = Range("C1").Value

For Each c In Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub