Custom Macro to Create New File from Data

**erock24** · 06-12-2009, 02:56 PM

I'm looking to create a new file from data in my table. I don't want to even imagine having to do this manually again...I'm optimistic there is a solution. All the data needed to create the file is in the table, but i need it stacked and organized in a weird way. It's almost to hard to explain...so I color coded an attachement that basically says it all. It's pretty much the same thing repeated over and over except the last 2 lines. It's just a really messed up organization.
In the real version I need the new file in a new workbook.
I'm extremely grateful to anyone who can automate this thing

Thank you.

**Chance2** · 06-12-2009, 06:54 PM

This code will create a sheet like "New File" without all the formating and then move it to a new book. You can save from there if that's what you want.

Sub SortData()
Dim strYear As String
Dim strCol As String

Dim lngRow As Long
Dim lngCol As Long
Dim lngCopyRow As Long
Dim lngCopyCol As Long

'Add a new sheet for the data
Application.DisplayAlerts = False
Sheets.Add After:=Sheets(Sheets("Data").Index)
Application.DisplayAlerts = True

'Set to the first data point
lngRow = 3

For lngCol = 3 To Sheets("Data").Range("C1").End(xlToRight).Column
    If IsEmpty(Range("A1")) = True Then
        lngCopyRow = 1
    Else
        lngCopyRow = Range("A1").End(xlDown).Row + 1
    End If
    'Header Row
    strYear = "000"
    strCol = Sheets("Data").Cells(1, lngCol)
    Range("A" & lngCopyRow) = "SM" & strYear & ":" & strCol & " MCS Name (16 Characters)"
    Range("A" & lngCopyRow + 1) = Sheets("Data").Cells(2, lngCol)
    lngCopyRow = lngCopyRow + 2
    Do Until IsEmpty(Sheets("Data").Range("A" & lngRow)) = True
        strYear = Right("000" & Sheets("Data").Range("A" & lngRow), 3)
        Range("A" & lngCopyRow) = "SM" & strYear & ":" & strCol & " MCS Schedule File Year #" & _
            Sheets("Data").Range("A" & lngRow) & " - " & Year(Sheets("Data").Range("B" & lngRow)) & _
            " (Jan-Dec)"
        For lngCopyCol = 1 To 12
            Cells(lngCopyRow + 1, lngCopyCol) = Sheets("Data").Cells(lngRow, lngCol)
            Cells(lngCopyRow + 1, lngCopyCol).NumberFormat = "0.000000"
            lngRow = lngRow + 1
        Next lngCopyCol
        lngCopyRow = lngCopyRow + 2
    Loop
    lngRow = 3
Next lngCol
Cells.EntireColumn.AutoFit
Range("A" & lngCopyRow) = "SN:01  #Schedule File Documentation Notes - Card Number:  1"
Range("A" & lngCopyRow + 1) = Sheets("Data").Cells(1, lngCol + 2)

ActiveSheet.Move

End Sub