copy calculation onto 300 sheets !?

[AmyTaylor]

I have a list of worksheets within my Excel file, they are on "sheet 1"
within the range: A1 to A300.

What I want to do, for each worksheet tab in the range, is copy cells:
A1999 to x2687 from a sheet called "report" into range: A1999 to
x2687.
The thing is that the file grinds to a halt if I do it manually, is it
possible to set it so that it runs for each sheet and is copied over as
values before going onto the next sheet ?

Any way you can think to make it less resource intensive would be great
!
Thanks
Amy xxx

 

[Guest]

Sub CopyToSheets()
Dim ThisCell as Range
For Each ThisCell in Worksheets("Sheet1").Range("A1:A300").Cells
Worksheets("report").Range("A1999:X2687").Copy
Worksheets(ThisCell.Text).Range("A1999:X2687").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next ThisCell
End Sub

 

[AmyTaylor]

Thanks K.Dales, that works great.

Can I ask you a further question, how could I set a macro t
automatically copy each of these sheets into individual Excel files ?
Ideally, the words "report for section" would appear on cell a1, and
I would want the sheet name to appear in cell a2 of the new file.
If possible, i would like to have the columns centered.
Is that possible ??
Thank you very much again
Amy xx

 

[tony h]

Dale,

I like your code. You could have selected all the worksheets first and
then done one paste but I don't think it is worth it for the additional
complexity in code unless performance is paramount.

Amy,
this is from a previous post on splitting workbooks:

A commented version

Option Explicit

Sub reMix()
Dim strSourcePath As String
Dim strSource As String
Dim strTarget As String
Dim strFiles(1 To 50) As String
Dim iFiles As Integer
Dim i As Integer

Dim wkbSource As Workbook
Dim wkbTarget As Workbook

Dim wksSource As Worksheet
Dim wksTarget As Worksheet
Dim wks As Worksheet

Dim str As String

'these define where the files are being taken from and being put
'it is assumed that:
' - all excel files in the source folder will be used
' - the target folder is empty
strSourcePath = ThisWorkbook.Path & "\source\"
strTarget = ThisWorkbook.Path & "\target\"

'create an arry of all the excel files
' have to do this as preprocess so that I can test for existence of
' the target file using the dir function
str = Dir(strSourcePath & "*.xls")
iFiles = 0
Do Until str = ""
iFiles = iFiles + 1
strFiles(iFiles) = str
str = Dir()
Loop


For i = 1 To iFiles 'loop through the source files
strSource = strFiles(i)
Set wkbSource = Workbooks.Open(strSourcePath & strSource)
For Each wks In wkbSource.Worksheets() 'loop through each worsheet in
the source file
str = strTarget & wks.Name & ".xls" 'use the sheet name to create an
output file name
If Dir(str) = "" Then 'see if the file exists. could do this with an
error trap, but it is messier
wks.Copy 'create a new book
Set wkbTarget = ActiveWorkbook
Set wksTarget = ActiveSheet
wkbTarget.SaveAs str
Else
Set wkbTarget = Workbooks().Open(str) ' add sheet to old book
wks.Copy wkbTarget.Worksheets(1)
Set wksTarget = ActiveSheet
End If

'name sheet with workbook name
wksTarget.Name = Left(wkbSource.Name, Len(wkbSource.Name) - 4)
Set wksTarget = Nothing

wkbTarget.Close xlYes
Set wkbTarget = Nothing
Next
wkbSource.Close xlNo
Set wkbSource = Nothing
Next
MsgBox "done"
End Sub

 

[Guest]

You can use the Worksheet.SaveAs method to save an individual sheet as a
separate file. Note below that I am using a variable FileName as the name
(path) for the file to save to - you did not say what that would be but
whatever it is you can set FileName at the point indicated in the code (where
I have FileName="???"). Also, by "columns centered" I assumed you meant all
the columns (including the ones copied in) but if you only meant A1 and A2
that is easy to fix by changing the line where HorizontalAlignment is set:

Sub CopyToSheetsAndFiles()
Dim ThisCell as Range, FileName as String
For Each ThisCell in Worksheets("Sheet1").Range("A1:A300").Cells
Worksheets("report").Range("A1999:X2687").Copy
Worksheets(ThisCell.Text).Range("A1999:X2687").PasteSpecial xlPasteValues
Application.CutCopyMode = False
With Worksheets(ThisCell.Text)
.Range("A1").Value = "Report for Section"
.Range("A2").Value = ThisCell.Text
.Range("A:X").HorizontalAlignment = xlHAlignCenter
FileName = "???"
.SaveAs FileName
End With
Next ThisCell
End Sub