Macro to copy only used cells

R

Rich

Hi, I have a macro which takes one 20000 line weeksheet, containing data
from 300 branches, and copies, pastes and saves to 300 new workbook
containing the data for each branch.

Each branch has a vaying number of lines of data, so my macro filters by
branch code, then copies the whole worksheet, including blank space.

this creates 4mb files, whereas if I manually copy and paste only the used
area of the workbook, it's less than 100k.

I therefore need a macro to highlight only the occupied cells. The number of
columns will always be the same (26), but number of rows varies.

Any ideas how to do this ?
 
B

Bob Phillips

Does each new worksheet therefore contain all of the data for all branches?
 
R

Rich

Bob Phillips said:
Does each new worksheet therefore contain all of the data for all
branches?

--
__________________________________
HTH

Bob
Click to expand...

No,

The original worksheet contains 300 branches in 20000 rows.

My macro filters by each branch before copying, pasting and saving.

The new workbooks each contain only one branches data, and are named branch
A, Branch B.
 
B

Bob Phillips

Then I am confused as to why it grows so big, I would only expect a doubling
(plus some for overheads), nowhere near 40 times.
 
R

Rich

Bob Phillips said:
Then I am confused as to why it grows so big, I would only expect a
doubling (plus some for overheads), nowhere near 40 times.

--
__________________________________
HTH

Bob
Click to expand...


It does end up 4 meg, whereas if I do the same thing manually, but only
highlight and copy the occupied cells, it's a little as 50k.

The branches download their 4mb files on a really slow network, so anxious
to resolve this.

Can anyone suggest a quick and dirty macro to copy only the populated cells,
or even just scroll down to the last row, and I'll work it from there.
 
W

Wullie

I have a macro which does the same work as yours (on a smaller scale) and it
works no problem (creating small files). Can you post your code so I can see
how it compares to mine?
 
R

Rich

Wullie said:
I have a macro which does the same work as yours (on a smaller scale) and
it
works no problem (creating small files). Can you post your code so I can
see
how it compares to mine?
Click to expand...




Here's the code:-

FERDCOPY()
'
' FERDCOPY Macro
' Macro recorded 02/09/2008 by Richard
'

'
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Columns("A:A").Select
Selection.EntireColumn.Hidden = True
Columns("E:E").ColumnWidth = 2
Columns("G:G").ColumnWidth = 2
Columns("I:I").ColumnWidth = 2
Columns("K:K").ColumnWidth = 2
Columns("M:M").ColumnWidth = 2
Columns("O:O").ColumnWidth = 2
Columns("Q:Q").ColumnWidth = 2
Columns("S:S").ColumnWidth = 2
Columns("U:AB").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
Application.CutCopyMode = False
With ActiveSheet.pagesetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.pagesetup.PrintArea = ""
With ActiveSheet.pagesetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub
Sub FERDSAVE()
'
' FERDSAVE Macro
' Macro recorded 02/09/2008 by Richard
'
' Keyboard Shortcut: Ctrl+n
'




ChDir "C:\Documents and Settings\Richard\Desktop\New Folder\FERD\SEP
FERD\FERD SF"
Dim WS As Worksheet
Set WS = ActiveSheet
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs WS.Range("B6") _
, FileFormat:=xlNormal, Password:="deleted",
WriteResPassword:="modify", _
ReadOnlyRecommended:=True, CreateBackup:=False
ActiveWindow.Close
End Sub

Sub FERDRUN()
'
' FERDRUN Macro
' Macro recorded 02/09/2008 by Richard
'
' Keyboard Shortcut: Ctrl+u
'
Range("A1").Select
Application.Run "PERSONAL.XLS!FERDCOPY"
Application.Run "PERSONAL.XLS!FERDSAVE"
End Sub
 
R

Rich

Rich said:
Here's the code:-

FERDCOPY()
'
' FERDCOPY Macro
' Macro recorded 02/09/2008 by Richard
'

'
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Columns("A:A").Select
Selection.EntireColumn.Hidden = True
Columns("E:E").ColumnWidth = 2
Columns("G:G").ColumnWidth = 2
Columns("I:I").ColumnWidth = 2
Columns("K:K").ColumnWidth = 2
Columns("M:M").ColumnWidth = 2
Columns("O:O").ColumnWidth = 2
Columns("Q:Q").ColumnWidth = 2
Columns("S:S").ColumnWidth = 2
Columns("U:AB").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
Application.CutCopyMode = False
With ActiveSheet.pagesetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.pagesetup.PrintArea = ""
With ActiveSheet.pagesetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub
Sub FERDSAVE()
'
' FERDSAVE Macro
' Macro recorded 02/09/2008 by Richard
'
' Keyboard Shortcut: Ctrl+n
'




ChDir "C:\Documents and Settings\Richard\Desktop\New Folder\FERD\SEP
FERD\FERD SF"
Dim WS As Worksheet
Set WS = ActiveSheet
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs WS.Range("B6") _
, FileFormat:=xlNormal, Password:="deleted",
WriteResPassword:="modify", _
ReadOnlyRecommended:=True, CreateBackup:=False
ActiveWindow.Close
End Sub

Sub FERDRUN()
'
' FERDRUN Macro
' Macro recorded 02/09/2008 by Richard
'
' Keyboard Shortcut: Ctrl+u
'
Range("A1").Select
Application.Run "PERSONAL.XLS!FERDCOPY"
Application.Run "PERSONAL.XLS!FERDSAVE"
End Sub
Click to expand...


I then run this for branches 1 to 300 :-

Selection.AutoFilter Field:=2, Criteria1:="BRANCH1"
Application.Run "FERDRUN"

Selection.AutoFilter Field:=2, Criteria1:="BRANCH2"
Application.Run "FERDRUN"

Selection.AutoFilter Field:=2, Criteria1:="BRANCH3"
Application.Run "FERDRUN"

I could do with knowing a better way to do this, I'll ask this as a seperate
thread.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Need Help with Macro Security 1
Increment Cell Value +1 with a macro 3
Next Line in Auto Filter Macro 2
PARSING DATA TO SHEETS 3
Copy Columns to New Sheet 4
Macro that sorts data with blanks at the bottom 1
Excel Macro Copy cells and pastes them in another sheet 2
OnTime Change_Event macro AND copy to sheet2 macro trouble 7

Top