here is my code...it's running a bit slow though..any ideas to make it more efficient? thanks

[Zarlot531]

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")
Columns("B:B").Select
Selection.Cut Destination:=Columns("C:C")
Columns("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:=xlDatabase,
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

 

[Leung]

Hi

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

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
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.

 

[Vergel Adriano]

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:=xlDatabase, 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