Adding a macro to copy worksheets
 

Hi

I am working on a Budget Template. What I want it do is to export the
data onto the worksheet called "Export". I have got it to work for the
first for the first cost centre, but want it to work through all
worksheets until it hits the worksheet "Last", because each business
can have a varying amount of cost centres. The macro to get things
started is "Export Data".

Could someone assist me. Here is my code.

Sub ExportData()
Export
del_rows
cc_calc1
value_Columns
Add_titles
Dups
End Sub

Sub Export()
On Error GoTo errtrap
Sheets("Export").Visible = True
Sheets("Export").Select
'Export_clear
Range("d1").Select
'For a = 2 To Sheets.Count
'If Worksheets(a).Visible = False Then
ActiveWorkbook.Worksheets(a).Visible = True
'Next a
For x = 7 To Sheets.Count - 2
ActiveWorkbook.Worksheets(x).Activate
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Sheets("Export").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
ActiveCell.SpecialCells(xlLastCell).Select
Selection.End(xlToLeft).Select
ActiveCell.Offset(1, -2).Select
Next x

errtrap:
Message = "You have either had an error, or this sucker has run its
course"
'Resume
End Sub

Sub del_rows()
On Error GoTo errtype
Intersect(ActiveSheet.UsedRange, Columns("d:d")). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Intersect(ActiveSheet.UsedRange, Columns("e:e")). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
errtype:
Message = "Oops looks like something went wrong"
Rows("1:1").Select
Selection.Insert Shift:=xlDown
End Sub


Sub cc_calc1()

Range("a2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[3]=R2C4,RC[4],R[-1]C)"
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(1, 0).Range("A1:A23").Select
ActiveSheet.Paste
ActiveCell.Offset(1, 1).Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(RC[2]=R4C4,RC[3],R[-1]C)"
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A22")
ActiveCell.Range("A1:A22").Select
ActiveCell.Offset(1, 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]&RC[1]"
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A21")
ActiveCell.Range("A1:A21").Select
ActiveWindow.SmallScroll Down:=12
ActiveCell.Offset(20, -2).Range("A1:C1").Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:C6209")
ActiveCell.Range("A1:C6209").Select
End Sub

Sub value_Columns()
Columns("A:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
On Error GoTo errtype
Intersect(ActiveSheet.UsedRange, Columns("f:f")). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
errtype:
Message = "Oops looks like something went wrong"
End Sub

Sub Add_titles()
Sheets("Export").Select
Range("a1").Activate
ActiveCell.FormulaR1C1 = "Cost Centre"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Fund Code"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Dup Chk"
Range("D1").Select
ActiveCell.FormulaR1C1 = "CI"
Range("E1").Select
ActiveCell.FormulaR1C1 = "CI2"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Tot"
Range("G1").Select
ActiveCell.FormulaR1C1 = "P1"
Range("H1").Select
ActiveCell.FormulaR1C1 = "P2"
Range("I1").Select
ActiveCell.FormulaR1C1 = "P3"
Range("J1").Select
ActiveCell.FormulaR1C1 = "P4"
Range("K1").Select
ActiveCell.FormulaR1C1 = "P5"
Range("L1").Select
ActiveCell.FormulaR1C1 = "P6"
Range("M1").Select
ActiveCell.FormulaR1C1 = "P7"
Range("N1").Select
ActiveCell.FormulaR1C1 = "P8"
Range("O1").Select
ActiveCell.FormulaR1C1 = "P9"
Range("P1").Select
ActiveCell.FormulaR1C1 = "P10"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "P11"
Range("R1").Select
ActiveCell.FormulaR1C1 = "P12"
Range("S1").Select
ActiveCell.FormulaR1C1 = "Garbage"
Range("S2").Select
End Sub

Sub Dups()
Dim iLastRow As Long
Dim i As Long
Dim sCells As String
Dim rng As Range
iLastRow = Cells(7599, "c").End(xlUp).Row 'Cells(Rows.Count, "c")
Set rng = Range("c1:c" & iLastRow)
For i = 1 To iLastRow
If Application.CountIf(rng, Cells(i, "c")) 1 Then
sCells = sCells & Cells(i, "c").Address(False, False) & ","
End If
Next i


If sCells < "" Then
sCells = Left(sCells, Len(sCells) - 1)
MsgBox "Duplicates found in " & vbCrLf & sCells
Else
MsgBox "No Duplicates found in " & vbCrLf & sCells
End If
End Sub

Thank you

Greg