Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > here is my code...it's running a bit slow though..any ideas to make it more efficient? thanks
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 11
Default here is my code...it's running a bit slow though..any ideas to make it more efficient? thanks
The problem could lie in the fact that I believe I'm having it scan
every single row several times. What I would like to do eventually is
run this macro on about 10 different sets of sheets at a time, getting
the pivot table report for each one. Basically, the problem i had
was that I had two reports I needed to run a pivot table on, but the
data were presented along with other text etc. and the reports rows
varied by day , etc. So, this macro creates the pivot table
information I need to find discprancies without me having to sort,
copy, paste, run the pivot table etc.

But, like I said, while it is still is going to save me time
(especially if I could do 10-15 at once), it's running slow.

Thanks for any suggestions.
__________________________________

Sub DelRw()
Dim lstRw
Dim i
Dim x
Dim CalcMode As Long
Dim Cell As Range
Dim g
Dim z
Dim MstRw
Dim ViewMode As Long





With Application
CalcMode = .Calculation
..Calculation = xlCalculationManual
..ScreenUpdating = False
End With
Sheets("52").Select
Columns("A").Select
Selection.TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(34, 1),
Array(42, 1), Array(52, 1), _
Array(54, 1), Array(66, 1), Array(76, 1), Array(86, 1),
Array(108, 1)), _
TrailingMinusNumbers:=True
Columns("C:G").Select
Selection.Delete Shift:=xlToLeft
lstRw = Cells(Rows.Count, 1).End(xlUp).Row
For i = lstRw To 1 Step -1
x = Cells(i, 3).Value
If Left(x, 4) < "2745" Then
Cells(i, 3).EntireRow.Delete
End If
Next

Columns("E").Select
For Each Cell In Selection
If Cell.Value = 0 Then
Cell.ClearContents
Else: Cell.Offset(0, -1).Value = Cell.Value * -1
Cell.ClearContents
End If
Next Cell
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Mar"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Amount"

Sheets("64").Select
Columns("A").Select
Selection.TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(26, 1), Array(48, 1),
Array(76, 1), Array(95, 1), _
Array(108, 1)), TrailingMinusNumbers:=True
Columns("F").Select
For Each Cell In Selection
If Cell.Value < "F" Then
Cell.ClearContents
Else
End If
Next


MstRw = Cells(Rows.Count, 1).End(xlUp).Row
For z = MstRw To 1 Step -1
g = Cells(z, 6).Value
If Left(g, 1) < "F" Then
Cells(z, 6).EntireRow.Delete
End If
Next
Columns("A").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("B").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("C:C").Select
Selection.Cut Destination:=Columns("D:D")
Columns("B:B").Select
Selection.Cut Destination:=Columns("C:C")
Columns("D:D").Select
Selection.Cut Destination:=Columns("B:B")
Columns("B:B").Select

For Each Cell In Selection
If Cell.Value 0 Then
Cell.Offset(0, -1).Value = 64
Else
End If
Next
Columns("C").Select
For Each Cell In Selection
If Cell.Value = 0 Then
Cell.ClearContents
Else: Cell.Offset(0, 1).Value = Cell.Value * -1
Cell.ClearContents
End If
Next Cell
Columns("C").Select
Selection.Delete Shift:=xlToLeft



Dim destSht As Worksheet
Dim srcSht As Worksheet
Dim NextRow As Long


Set destSht = Sheets("52")
Set srcSht = Sheets("64")


NextRow = destSht.Cells(destSht.Rows.Count, 1).End(xlUp).Row + 1


'source sheet has a heading that I have to exclude from copy
srcSht.Cells(1).CurrentRegion.Copy


'I can choose to paste values
destSht.Cells(NextRow, 1).PasteSpecial xlPasteAll

Sheets("52").Select
Columns("A:C").Select
Range("C1").Activate
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatab ase,
SourceData:= _
"'52'!A1:C65536").CreatePivotTable TableDestination:="",
TableName:= _
"PivotTable2", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard
TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:="Mar",
_
ColumnFields:="Code"
With ActiveSheet.PivotTables("PivotTable2").PivotFields ("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With






End Sub

Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 119
Default here is my code...it's running a bit slow though..any ideas to mak
Hi

I think the major problem is that you try to put whole of spreadsheet into
the Pivot Caches.

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatab ase, _
SourceData:= "'52'!A1:C65536")


Try to use find to locate the cell that is the top left of data then use
select xldown and select right to retrive the address of the data range that
you need to perform pivot table.

1. use find to locate the lable which listing the data
2. use offset in case which is the next cell or the cell below
3. then use select right and select down, or select down then select right

i think as long as you elimiate those unnecessary cells then it will help to
speed up.

hope this help.


"Zarlot531" wrote:

The problem could lie in the fact that I believe I'm having it scan
every single row several times. What I would like to do eventually is
run this macro on about 10 different sets of sheets at a time, getting
the pivot table report for each one. Basically, the problem i had
was that I had two reports I needed to run a pivot table on, but the
data were presented along with other text etc. and the reports rows
varied by day , etc. So, this macro creates the pivot table
information I need to find discprancies without me having to sort,
copy, paste, run the pivot table etc.

But, like I said, while it is still is going to save me time
(especially if I could do 10-15 at once), it's running slow.

Thanks for any suggestions.
__________________________________

Sub DelRw()
Dim lstRw
Dim i
Dim x
Dim CalcMode As Long
Dim Cell As Range
Dim g
Dim z
Dim MstRw
Dim ViewMode As Long





With Application
CalcMode = .Calculation
..Calculation = xlCalculationManual
..ScreenUpdating = False
End With
Sheets("52").Select
Columns("A").Select
Selection.TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(34, 1),
Array(42, 1), Array(52, 1), _
Array(54, 1), Array(66, 1), Array(76, 1), Array(86, 1),
Array(108, 1)), _
TrailingMinusNumbers:=True
Columns("C:G").Select
Selection.Delete Shift:=xlToLeft
lstRw = Cells(Rows.Count, 1).End(xlUp).Row
For i = lstRw To 1 Step -1
x = Cells(i, 3).Value
If Left(x, 4) < "2745" Then
Cells(i, 3).EntireRow.Delete
End If
Next

Columns("E").Select
For Each Cell In Selection
If Cell.Value = 0 Then
Cell.ClearContents
Else: Cell.Offset(0, -1).Value = Cell.Value * -1
Cell.ClearContents
End If
Next Cell
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Mar"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Amount"

Sheets("64").Select
Columns("A").Select
Selection.TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(26, 1), Array(48, 1),
Array(76, 1), Array(95, 1), _
Array(108, 1)), TrailingMinusNumbers:=True
Columns("F").Select
For Each Cell In Selection
If Cell.Value < "F" Then
Cell.ClearContents
Else
End If
Next


MstRw = Cells(Rows.Count, 1).End(xlUp).Row
For z = MstRw To 1 Step -1
g = Cells(z, 6).Value
If Left(g, 1) < "F" Then
Cells(z, 6).EntireRow.Delete
End If
Next
Columns("A").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("B").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("C:C").Select
Selection.Cut Destination:=Columns("D:D")
Columns("B:B").Select
Selection.Cut Destination:=Columns("C:C")
Columns("D:D").Select
Selection.Cut Destination:=Columns("B:B")
Columns("B:B").Select

For Each Cell In Selection
If Cell.Value 0 Then
Cell.Offset(0, -1).Value = 64
Else
End If
Next
Columns("C").Select
For Each Cell In Selection
If Cell.Value = 0 Then
Cell.ClearContents
Else: Cell.Offset(0, 1).Value = Cell.Value * -1
Cell.ClearContents
End If
Next Cell
Columns("C").Select
Selection.Delete Shift:=xlToLeft



Dim destSht As Worksheet
Dim srcSht As Worksheet
Dim NextRow As Long


Set destSht = Sheets("52")
Set srcSht = Sheets("64")


NextRow = destSht.Cells(destSht.Rows.Count, 1).End(xlUp).Row + 1


'source sheet has a heading that I have to exclude from copy
srcSht.Cells(1).CurrentRegion.Copy


'I can choose to paste values
destSht.Cells(NextRow, 1).PasteSpecial xlPasteAll

Sheets("52").Select
Columns("A:C").Select
Range("C1").Activate
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatab ase,
SourceData:= _
"'52'!A1:C65536").CreatePivotTable TableDestination:="",
TableName:= _
"PivotTable2", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard
TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:="Mar",
_
ColumnFields:="Code"
With ActiveSheet.PivotTables("PivotTable2").PivotFields ("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With






End Sub


Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 857
Default here is my code...it's running a bit slow though..any ideas to mak
Give this a try. Try this on a backup copy and step through the code so that
you would find anything that I might have missed. The basic idea is that most
of the time, you don't really need to select the range to perform an
operation. Also when looping through cells, you can put all the cells in a
range as you go through them and then delete them one time at the end rather
than deleting them at each iteration...


Sub DelRw()

Dim lstRw As Long
Dim i As Long
Dim x As String
Dim CalcMode As Long
Dim Cell As Range
Dim rDel As Range


With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With Sheets("52")
.Range("A:A").TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(34, 1), Array(42,
1), Array(52, 1), _
Array(54, 1), Array(66, 1), Array(76, 1), Array(86, 1), Array(108,
1)), _
TrailingMinusNumbers:=True

.Columns("C:G").Delete Shift:=xlToLeft
lstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = lstRw To 1 Step -1
x = .Cells(i, 3).Value
If Left(x, 4) < "2745" Then
If rDel Is Nothing Then
Set rDel = .Cells(i, 3)
Else
Set rDel = Application.Union(rDel, .Cells(i, 3))
End If
End If
Next
If Not rDel Is Nothing Then rDel.EntireRow.Delete

lstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rDel = Nothing
For Each Cell In .Range("E1:E" & lstRw)
If Cell.Value < 0 Then
Cell.Offset(0, -1).Value = Cell.Value * -1
End If
If rDel Is Nothing Then
Set rDel = Cell
Else
Set rDel = Application.Union(rDel, Cell)
End If
Next Cell
If Not rDel Is Nothing Then rDel.ClearContents

.Columns("C").Delete Shift:=xlToLeft
.Rows("1:1").Insert Shift:=xlDown
.Range("A1").FormulaR1C1 = "Code"
.Range("B1").FormulaR1C1 = "Mar"
.Range("C1").FormulaR1C1 = "Amount"

End With

With Sheets("64")
.Range("A:A").TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(26, 1), Array(48, 1),
Array(76, 1), Array(95, 1), _
Array(108, 1)), TrailingMinusNumbers:=True

lstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rDel = Nothing
For Each Cell In .Range("F1:F" & lstRw)
If Left(Cell.Value, 1) < "F" Then
If rDel Is Nothing Then
Set rDel = Cell
Else
Set rDel = Application.Union(rDel, Cell)
End If
End If
Next
If Not rDel Is Nothing Then rDel.EntireRow.Delete

.Columns("A").Delete Shift:=xlToLeft
.Columns("C:E").Delete Shift:=xlToLeft
.Columns("A").Insert Shift:=xlToRight
.Columns("C").Cut Destination:=.Columns("D")
.Columns("B").Cut Destination:=.Columns("C")
.Columns("D").Cut Destination:=.Columns("B")

lstRw = .Cells(.Rows.Count, 2).End(xlUp).Row
For Each Cell In .Range("B1:B" & lstRw)
If Cell.Value 0 Then
Cell.Offset(0, -1).Value = 64
End If
Next

Set rDel = Nothing
For Each Cell In .Range("C1:C" & lstRw)
If Cell.Value < 0 Then
Cell.Offset(0, 1).Value = Cell.Value * -1
End If
If rDel Is Nothing Then
Set rDel = Cell
Else
Set rDel = Application.Union(rDel, Cell)
End If
Next Cell
If Not rDel Is Nothing Then rDel.ClearContents

Columns("C").Delete Shift:=xlToLeft

End With

Dim destSht As Worksheet
Dim srcSht As Worksheet
Dim NextRow As Long
Set destSht = Sheets("52")
Set srcSht = Sheets("64")

NextRow = destSht.Cells(destSht.Rows.Count, 1).End(xlUp).Row + 1

'source sheet has a heading that I have to exclude from copy
srcSht.Cells(1).CurrentRegion.Copy

'I can choose to paste values
destSht.Cells(NextRow, 1).PasteSpecial xlPasteAll

lstRw = destSht.UsedRange.SpecialCells(xlCellTypeLastCell) .Row

Sheets("52").Select
Columns("A:C").Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatab ase, SourceData:= _
"'52'!A1:C" & lstRw).CreatePivotTable TableDestination:="",
TableName:= _
"PivotTable2", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:="Mar", _
ColumnFields:="Code"
With ActiveSheet.PivotTables("PivotTable2").PivotFields ("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With


End Sub



--
Hope that helps.

Vergel Adriano


"Zarlot531" wrote:

The problem could lie in the fact that I believe I'm having it scan
every single row several times. What I would like to do eventually is
run this macro on about 10 different sets of sheets at a time, getting
the pivot table report for each one. Basically, the problem i had
was that I had two reports I needed to run a pivot table on, but the
data were presented along with other text etc. and the reports rows
varied by day , etc. So, this macro creates the pivot table
information I need to find discprancies without me having to sort,
copy, paste, run the pivot table etc.

But, like I said, while it is still is going to save me time
(especially if I could do 10-15 at once), it's running slow.

Thanks for any suggestions.
__________________________________

Sub DelRw()
Dim lstRw
Dim i
Dim x
Dim CalcMode As Long
Dim Cell As Range
Dim g
Dim z
Dim MstRw
Dim ViewMode As Long





With Application
CalcMode = .Calculation
..Calculation = xlCalculationManual
..ScreenUpdating = False
End With
Sheets("52").Select
Columns("A").Select
Selection.TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(20, 1), Array(34, 1),
Array(42, 1), Array(52, 1), _
Array(54, 1), Array(66, 1), Array(76, 1), Array(86, 1),
Array(108, 1)), _
TrailingMinusNumbers:=True
Columns("C:G").Select
Selection.Delete Shift:=xlToLeft
lstRw = Cells(Rows.Count, 1).End(xlUp).Row
For i = lstRw To 1 Step -1
x = Cells(i, 3).Value
If Left(x, 4) < "2745" Then
Cells(i, 3).EntireRow.Delete
End If
Next

Columns("E").Select
For Each Cell In Selection
If Cell.Value = 0 Then
Cell.ClearContents
Else: Cell.Offset(0, -1).Value = Cell.Value * -1
Cell.ClearContents
End If
Next Cell
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Code"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Mar"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Amount"

Sheets("64").Select
Columns("A").Select
Selection.TextToColumns Destination:=Range("A1"),
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(26, 1), Array(48, 1),
Array(76, 1), Array(95, 1), _
Array(108, 1)), TrailingMinusNumbers:=True
Columns("F").Select
For Each Cell In Selection
If Cell.Value < "F" Then
Cell.ClearContents
Else
End If
Next


MstRw = Cells(Rows.Count, 1).End(xlUp).Row
For z = MstRw To 1 Step -1
g = Cells(z, 6).Value
If Left(g, 1) < "F" Then
Cells(z, 6).EntireRow.Delete
End If
Next
Columns("A").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("C").Select
Selection.Delete Shift:=xlToLeft
Columns("B").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("C:C").Select
Selection.Cut Destination:=Columns("D:D")
Columns("B:B").Select
Selection.Cut Destination:=Columns("C:C")
Columns("D:D").Select
Selection.Cut Destination:=Columns("B:B")
Columns("B:B").Select

For Each Cell In Selection
If Cell.Value 0 Then
Cell.Offset(0, -1).Value = 64
Else
End If
Next
Columns("C").Select
For Each Cell In Selection
If Cell.Value = 0 Then
Cell.ClearContents
Else: Cell.Offset(0, 1).Value = Cell.Value * -1
Cell.ClearContents
End If
Next Cell
Columns("C").Select
Selection.Delete Shift:=xlToLeft



Dim destSht As Worksheet
Dim srcSht As Worksheet
Dim NextRow As Long


Set destSht = Sheets("52")
Set srcSht = Sheets("64")


NextRow = destSht.Cells(destSht.Rows.Count, 1).End(xlUp).Row + 1


'source sheet has a heading that I have to exclude from copy
srcSht.Cells(1).CurrentRegion.Copy


'I can choose to paste values
destSht.Cells(NextRow, 1).PasteSpecial xlPasteAll

Sheets("52").Select
Columns("A:C").Select
Range("C1").Activate
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatab ase,
SourceData:= _
"'52'!A1:C65536").CreatePivotTable TableDestination:="",
TableName:= _
"PivotTable2", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard
TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:="Mar",
_
ColumnFields:="Code"
With ActiveSheet.PivotTables("PivotTable2").PivotFields ("Amount")
.Orientation = xlDataField
.Caption = "Sum of Amount"
.Function = xlSum
End With






End Sub


Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Hybrid Mode Hybrid Mode

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

Similar Threads
Thread Thread Starter Forum Replies Last Post
Slow code needs speeding up!....any ideas??.... WhytheQ Excel Programming 4 March 8th 07 12:25 PM
Slow Running Code to Hide Blank Rows Aaron Excel Programming 3 January 10th 07 03:17 AM
How can I make this code more efficient? Sethaholic[_27_] Excel Programming 1 August 1st 06 05:15 PM
need to make code more efficient (if possible) Lilivati Excel Programming 8 July 7th 06 07:50 PM
code running super slow... gaba Excel Programming 3 November 20th 04 02:35 AM


All times are GMT +1. The time now is 03:47 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement