need some code to move items into new sheets

[Immatoity]

hi

I have one long list dloaded from Sage.. now in Excel 2003.

Columns A-E are populated.

I need some VBA that will look down column A ( which contains supplier names) and every time it comes across a "new/diff" one I want it to cut that data for that supplier and put it in a new sheet and also name the tab the same as the supplier , essentially leaving me with multiple tabs with each supplier's data in it alone.

The data is already sorted by column A ( supplier name)

ta

[Bob Phillips]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim StartRow As Long
Dim shName As String
Dim This As Worksheet
Dim Sh As Worksheet

Set This = ActiveSheet
With This

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
StartRow = 1
For i = 1 To LastRow

If .Cells(i, "A").Value <> .Cells(i + 1, "A").Value Then

shName = .Cells(i, "A").Value
Set Sh = AddSheet(shName)
.Rows(StartRow).Resize(i - StartRow + 1).Copy Sh.Range("A1")
StartRow = i + 1
End If
Next i

.Activate
End With

End Sub


Function AddSheet(Sh As String, _
Optional wb As Workbook) As Worksheet
Dim SheetExists As Boolean
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error GoTo 0
Application.DisplayAlerts = False
If SheetExists Then wb.Worksheets(Sh).Delete
Application.DisplayAlerts = True
wb.Worksheets.Add after:=wb.Worksheets(wb.Worksheets.Count)
Set AddSheet = ActiveSheet
AddSheet.Name = Sh
End Function

[Immatoity]

amazing thanks ever so much!!

could I tweak it so it only copies the items held in columns C & D to the new tabs and copies the data to A8 in each tab (as each tab has a header etc)

[Bob Phillips]

could I tweak it so it only copies the items held in columns C & D to the new tabs and copies the data to A8 in each tab (as each tab has a header etc)

You could try ;)



Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim StartRow As Long
Dim shName As String
Dim This As Worksheet
Dim Sh As Worksheet

Set This = ActiveSheet
With This

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
StartRow = 1
For i = 1 To LastRow

If .Cells(i, "A").Value <> .Cells(i + 1, "A").Value Then

shName = .Cells(i, "A").Value
Set Sh = AddSheet(shName)
.Cells(StartRow, "C").Resize(i - StartRow + 1, 2).Copy Sh.Range("A8")
StartRow = i + 1
End If
Next i

.Activate
End With

End Sub


Function AddSheet(Sh As String, _
Optional wb As Workbook) As Worksheet
Dim SheetExists As Boolean
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = CBool(Not wb.Worksheets(Sh) Is Nothing)
On Error Goto 0
Application.DisplayAlerts = False
If SheetExists Then wb.Worksheets(Sh).Delete
Application.DisplayAlerts = True
wb.Worksheets.Add after:=wb.Worksheets(wb.Worksheets.Count)
Set AddSheet = ActiveSheet
AddSheet.Name = Sh
End Function

[Immatoity]

thank you again xld...

one last favour on this task please

I have multiple sheets now (which I wanted)...

I need to print preview all of these as they all need to be setup to print to one page first.. is there any VBA to do this..

I think 80%, margins 0.5 all round and portrait will do it but I dont know how to "assign" these parameters to each sheet with VBA

I tried recording but it seems to "loop" and I want it to go through all sheets for me not just go to the next.. this is not the most elegant of coding by me

Keyboard Shortcut: Ctrl+Shift+P
'
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.354330708661417)
.RightMargin = Application.InchesToPoints(0.354330708661417)
.TopMargin = Application.InchesToPoints(0.196850393700787)
.BottomMargin = Application.InchesToPoints(0.196850393700787)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.Next.Select

End Sub

[Bob Phillips]

Sub SetupAll()
Dim sh As Worksheet

For Each sh In ActiveWorkbook.Worksheets

With sh.PageSetup

.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.354330708661417)
.RightMargin = Application.InchesToPoints(0.354330708661417)
.TopMargin = Application.InchesToPoints(0.196850393700787)
.BottomMargin = Application.InchesToPoints(0.196850393700787)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Next sh
End Sub

[Immatoity]

hi..tried using this again today... but it fails? I get an error code "400"..no idea what that means..

it creates 23 sheets then fails..no idea why.. I have no blank rows or anything

EDIT : worked it out..one of the supplier names had a "/" in it..hence the naming of sheet failed..doh

[Bob Phillips]

Post the workbook.