1 Attachment(s)
My First Macro Task - Please Help
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. :sick:
Re: My First Macro Task - Please Help
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.
VB Code:
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
Re: My First Macro Task - Please Help
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 :blush:
Re: My First Macro Task - Please Help
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.
VB Code:
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
Re: My First Macro Task - Please Help
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!
Re: My First Macro Task - Please Help
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.
VB Code:
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
Re: My First Macro Task - Please Help
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. ;)
VB Code:
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?
