My First Macro Task - Please Help

[harjit]

I have an excel spreadsheet which I need to write macro for. The followings is what I need to do
For every new spreadsheet, it should have
1) the header
2) the legion
3) data (different data according to customer codes, so if there are 12 customer codes i'll have 12 different spreadsheets,the only similarity will be the header and legion.)
I need to copy paste all this in a newspreadsheet and save it according to different customer codes.Im not suppose to hard code the location (rows,columns) since the location of data keeps changing from time to time.
Does anyone have any idea how I can go about with this? If there's any examples I can look into,please do forward it to me.Would really appreciate it.Please help as this is my first macro task. Thank you so much.

[queenb2005]

Well you can start with your auto_open macro. That will automatically run when your that excel file is open. You could create make an input box pop up, input the number of sheets and what you need to add to the Header. Here is an example.

Public Sub auto_open()
 
Sheets("Sheet1").Activate
Application.ScreenUpdating = False
ctr = 1
Number = InputBox$("How many sheets do you  need?")
Entry = InputBox$("Put header title here")
Number = Number - 1
While ctr <= Number
    With ActiveSheet.PageSetup
        .CenterHeader = "&P of &N"
        .LeftHeader = Entry
        .RightHeader = "&D" & Chr(10) & "&T"
    End With
    ActiveSheet.DisplayAutomaticPageBreaks = False
    Sheets.Add
    ctr = ctr + 1
Wend
 
End Sub

It's not super fast put it adds the sheets and places header info.
~Queen B

[harjit]

THanks!But thats not what I want ,im so sorry,you see there's only one spreadsheet with countless of customer codes,each with different data,i need to break each and every customer code together with their data into separate spreadsheets.All the spreadsheets with have the same header and legion.One customer code,one spreadsheet.The only thing that differs is the customer code and its data.I also need to save each of the spreadsheets according to their customer codes.So for ex : customer code is - ADI the filename should be ADI.xls.Can you help me plz?I hope u understand what im trying to say

[mikeyc1204]

Not sure what Legion is so I didn't include it in the code. You can fill in that part if this is useful


This code requires you to edit a few things: The 3 constants at the top
topRowOfData = the first row that your customer code data starts.
custCodeCol = the column the customer code is in. If its in Column A, put 1. If its in column D, put 4.
And saveDir = the directory you want to save your sheets. Include the "\" at the end.

Further assumptions this code makes are:
There is a row above your top row of data that contains column headings.
Everything above that set of column headings is counted as your header.
There are no empty rows between your rows of data.

Assuming all of this is accurate, the code below will make one spreadsheet for every customer code, with the same headings as the original sheet.

If ANY of these assumptions are wrong, let me know and I can update the code accordingly.

Sub SplitCustomerCodes()
 
    Const topRowOfData = 6
    Const custCodeCol = 1
    Const saveDir = "C:\tmp\"
    
    Dim custCodes() As String, custCodeCount As Integer, ccFound As Boolean, curCC As String
    Dim legion As String
    Dim i As Integer, j As Integer
    Dim thisBook As String, wipBook As String
    
    thisBook = ActiveWorkbook.Name
    ccFound = False
    ReDim custCodes(0)
    
    For i = topRowOfData To Cells(topRowOfData, custCodeCol).End(xlDown).Row
        curCC = Cells(i, custCodeCol).Value
        For j = 0 To UBound(custCodes)
            If custCodes(j) = curCC Then ccFound = True
        Next j
        If Not ccFound Then
            custCodeCount = custCodeCount + 1
            ReDim Preserve custCodes(custCodeCount - 1)
            custCodes(custCodeCount - 1) = curCC
        End If
        ccFound = False
    Next i
    
    Rows(topRowOfData - 1 & ":" & topRowOfData - 1).AutoFilter
    For i = 0 To UBound(custCodes)
        Rows(topRowOfData - 1 & ":" & topRowOfData - 1).AutoFilter Field:=custCodeCol, Criteria1:=custCodes(i)
        Rows(topRowOfData & ":" & Cells(topRowOfData, custCodeCol).End(xlDown).Row).Copy
        
        Workbooks.Add
        wipBook = ActiveWorkbook.Name
        
        Rows(topRowOfData & ":" & topRowOfData).PasteSpecial xlPasteAll
        Windows(thisBook).Activate
        Range(Cells(1, 1), Cells(topRowOfData - 1, 256)).Copy
        Windows(wipBook).Activate
        Range("A1").PasteSpecial xlPasteAll
        Range("A1").Select
        
        'paste Legion
        
        ActiveWorkbook.SaveAs Filename:=saveDir & custCodes(i) & ".xls"
        ActiveWorkbook.Close
    Next i
    Rows(topRowOfData - 1 & ":" & topRowOfData - 1).AutoFilter
    
End Sub

[harjit]

Hey mate!Thanks yea,that was very kind of you,the thing is im not suppose to hard code this since the column n rows of the spreadsheet will keep changing in the future and there are empty rows here and there in the spreadsheet.Ive managed to upload the attachment for your reference(Refer to my first thread)I preety much think u'll have a clearer idea about my task.Now you dunt have to give me you e mail add Thank you so much!

[mikeyc1204]

This code is tailored specifically to the file you attached in your post:

You need only change the constant at the top to reflect your base directory where you want your files and folders saved.

Sub splitCustomers()
 
    Const baseDir = "c:\tmp\"
    
    Dim lastRow As Integer, curRow As Integer
    Dim topRow As Integer, bottomRow As Integer
    Dim company As String
    Dim newCompany As Boolean
    Dim thisBook As String, wipBook As String
    
    lastRow = Range("A" & 256 ^ 2).End(xlUp).Row
    thisBook = ActiveWorkbook.Name
    curRow = 4
    newCompany = True
    
    Do While curRow <= lastRow
        If newCompany Then
            newCompany = False
            topRow = curRow
        End If
        If Left(Cells(curRow, 1).Value, 19) = "Total by Customer :" Then
            company = Mid(Cells(curRow, 1).Value, 21)
            bottomRow = curRow + 2
            
            Rows("1:3").Copy
            Workbooks.Add
            wipBook = ActiveWorkbook.Name
            Range("A1").PasteSpecial xlPasteAll
            Windows(thisBook).Activate
            Rows(topRow & ":" & bottomRow).Copy
            Windows(wipBook).Activate
            Range("A4").PasteSpecial xlPasteAll
            bottomRow = Range("A" & 256 ^ 2).End(xlUp).Row + 3
            Windows(thisBook).Activate
            Rows(lastRow + 3 & ":" & lastRow + 3).Copy
            Windows(wipBook).Activate
            Range("A" & bottomRow).PasteSpecial xlPasteColumnWidths
            Range("A" & bottomRow).PasteSpecial xlPasteAll
            Range("A4").Select
            ActiveWorkbook.Names.Add Name:="company", RefersToR1C1:="=""" & Trim(company) & """"
            Call MakeCompanyDir(baseDir, Trim(company))
            ActiveWorkbook.SaveAs Filename:=baseDir & Trim(company) & "\" & Trim(company) & ".xls"
            ActiveWorkbook.Close
            curRow = curRow + 2
            newCompany = True
        End If
        curRow = curRow + 1
    Loop
 
End Sub
 
Sub MakeCompanyDir(base As String, co As String)
    On Error Resume Next
    MkDir base & co
End Sub

[harjit]

Hey mate!Your program works perfectly alrite,i manage to do some changes n it works good.Thank you so much!Anyways this is how it looks.It would be great if you can explain the codes to me as I am a little unsure about some part of the codes here.Thank you so much Michael.

Sub Auto_open()
 
Const baseDir = "c:\tmp\"
    
    Dim lastRow As Integer, curRow As Integer
    Dim topRow As Integer, bottomRow As Integer
    Dim company As String
    Dim newCompany As Boolean
    Dim thisBook As String, wipBook As String
    
    lastRow = Range("A" & 256 ^ 2).End(xlUp).Row
    thisBook = ActiveWorkbook.Name
    curRow = 4
    newCompany = True
    
    Do While curRow <= lastRow
        If newCompany Then
            newCompany = False
            topRow = curRow
        End If
        If Left(Cells(curRow, 1).Value, 19) = "Total by Customer :" Then
            company = Mid(Cells(curRow, 1).Value, 21)
            bottomRow = curRow + 2
            Application.DisplayAlerts = False
            Rows("1:3").Copy
            Workbooks.Add
            wipBook = ActiveWorkbook.Name
            Range("A1").PasteSpecial xlPasteAll
            Windows(thisBook).Activate
            Rows(topRow & ":" & bottomRow).Copy
            Windows(wipBook).Activate
            Range("A4").PasteSpecial xlPasteAll
            bottomRow = Range("A" & 256 ^ 2).End(xlUp).Row + 3
            Windows(thisBook).Activate
            Rows(lastRow + 3 & ":" & lastRow + 3).Copy
            Windows(wipBook).Activate
            Range("A" & bottomRow).PasteSpecial xlPasteAll
            Range("A4").Select
            ActiveWorkbook.Names.Add Name:="company", RefersToR1C1:="=""" & Trim(company) & """"
            Call MakeCompanyDir(baseDir, Trim(company))
            ActiveWorkbook.SaveAs Filename:=baseDir & Trim(company) & "\" & "S" & Format(Now(), "yyyymmdd") & ".xls"
            ActiveWorkbook.Close
            curRow = curRow + 2
            newCompany = True
            ActiveCell.HorizontalAlignment = xlRight
            ActiveCell.HorizontalAlignment = xlLeft
            ActiveCell.HorizontalAlignment = xlCenter
            Columns("C:C").EntireColumn.AutoFit
            Selection.RowHeight = 25#
        End If
        curRow = curRow + 1
    Loop
    ActiveWorkbook.Close
 
End Sub
 
Sub MakeCompanyDir(base As String, co As String)
    On Error Resume Next
    MkDir base & co
End Sub

Note* If new customer codes and data are added in the spreadsheet,would it still work like it does now?