PC Review


Reply
Thread Tools Rate Thread

Adding a macro to copy worksheets

 
 
Gregc.
Guest
Posts: n/a
 
      30th Jan 2008
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
 
Reply With Quote
 
 
 
Reply

Thread Tools
Rate This Thread
Rate This Thread:

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are Off


Similar Threads
Thread Thread Starter Forum Replies Last Post
Adding macro buttons to new worksheets =?Utf-8?B?bm9zcGFtaW5saWNo?= Microsoft Excel Programming 2 13th Nov 2006 05:25 PM
Copy worksheets from one WB to another with external Macro shabb090177 Microsoft Excel Programming 2 23rd Jun 2006 08:08 PM
macro to copy into different worksheets =?Utf-8?B?c2FyYWhwaG9uaWNz?= Microsoft Excel Misc 2 30th Jun 2005 03:16 PM
Macro to Copy Worksheets =?Utf-8?B?Sk4=?= Microsoft Excel Worksheet Functions 0 17th Apr 2005 01:50 AM
Adding & Naming Worksheets in a macro John Microsoft Excel Misc 3 5th Mar 2004 05:13 PM


Features
 

Advertising
 

Newsgroups
 


All times are GMT +1. The time now is 03:44 AM.