VBA template is not processing 60000 rows

M

mosheva

New Member
Joined
Sep 11, 2013
Messages
15
Hello,

I'm using the following VBA code to order a template. if I try to use it on a 60000 rows it will only process the first row.
Please let me know if you know the reason... thanks!

Code: 
Option Explicit
Sub AddRowsSummary()
On Error GoTo ErrAddRowsSummary


Dim StartCol As String, EndCol As String, SourceDataCol As Long
Dim tmpCell1s As String, tmpCell2s As String
Dim tmpCell1d As String, tmpCell2d As String
Dim SourceWSName As String, DestWSName As String
Dim StartRow As Long, EndRow As Long, SourceStartRow As Long, RowCount As Long, LastRowForNewTable As Long
Dim SourceWS As Excel.Worksheet, DestWS As Excel.Worksheet
Dim TotalsRange As String, i As Integer
Dim AmountCell, AmountCol, AmountRange As String
Dim iColCount As Long, j As Long
Dim tmpCell1 As String, tmpCell2 As String, tmpCell1send As String
StartCol = "A" '"B"
SourceDataCol = 12 '4
StartRow = 1   '2   '16
SourceStartRow = 1   '2
SourceWSName = "DATA"
DestWSName = "PRINT"
TotalsRange = "L16:U18"
'AmountCol = "J"
'AmountRange = ""
'AmountCell = "J" '"J22"


Set SourceWS = Application.ActiveWorkbook.Sheets(SourceWSName)
Set DestWS = Application.ActiveWorkbook.Sheets(DestWSName)
DestWS.Select


RowCount = 0
While SourceWS.Cells(SourceStartRow + 1 + RowCount, SourceDataCol).Value <> ""
    RowCount = RowCount + 1
Wend
iColCount = 0
While SourceWS.Cells(SourceStartRow + 1, SourceDataCol + iColCount).Value <> ""
    iColCount = iColCount + 1
Wend
EndCol = GetColumn(iColCount)
'Captions
tmpCell1s = GetColumn(SourceDataCol) & StartRow
tmpCell1d = StartCol & StartRow
'DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & ")"
DestWS.Range(tmpCell1d).Formula = "=IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & "0" & Chr(34) & ",DATA!" & tmpCell1s & ")"
'First row of data
tmpCell1s = GetColumn(SourceDataCol) & StartRow + 1
tmpCell1d = StartCol & StartRow + 1
'If IsNumeric(CStr(SourceWS.Range(tmpCell1s).Value)) Then
    'DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & " * 1)"
'Else
                                       '=IF(DATA!                AB5=  ""                  ,                            " ",IF(ISERROR(DATA!   AB5*1         ), DATA!AB5, DATA!AB5*1))
    '################# WAS WITH *1 in the end... Yakir, 21/12/2011
     'DestWS.Range(tmpCell1d).Formula = "=IF(IsADate(DATA!" & tmpCell1s & "),DATA!" & tmpCell1s & ",(IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & " " & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "*1))))"
     DestWS.Range(tmpCell1d).Formula = "=IF(IsADate(DATA!" & tmpCell1s & "),DATA!" & tmpCell1s & ",(IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & " " & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "))))"
    ''DestWS.Range(tmpCell1d).Formula = "=IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & "0" & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "*1))"
'End If
If RowCount > 0 Then
    EndRow = StartRow + RowCount - 1
     For j = 0 To iColCount - 1
        'copy formula for captions's row
       tmpCell1s = GetColumn(SourceDataCol + j) & StartRow + 1
       tmpCell1d = GetColumn(Asc(StartCol) + j - Asc("A") + 1) & StartRow + 1
       'DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & ")"
       'DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",IF (IsNumeric(DATA!" & tmpCell1s & "),(DATA!" & tmpCell1s & ") * 1, DATA!" & tmpCell1s & "))"
      ''  DestWS.Range(tmpCell1d).Formula = "=IF(IsADate(DATA!M3),DATA!M3,IF(ISNUMBER(DATA!M3),"0",IF(ISERROR(DATA!M3*1), DATA!M3, DATA!M3*1)))
        '################# WAS WITH *1 in the end... Yakir, 21/12/2011
        'DestWS.Range(tmpCell1d).Formula = "=IF(IsADate(DATA!" & tmpCell1s & "),DATA!" & tmpCell1s & ",(IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & " " & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "*1))))"
        DestWS.Range(tmpCell1d).Formula = "=IF(IsADate(DATA!" & tmpCell1s & "),DATA!" & tmpCell1s & ",(IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & " " & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "))))"
      '' DestWS.Range(tmpCell1d).Formula = "=IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & "0" & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "*1))"
        'If IsNumeric(CStr(SourceWS.Range(tmpCell1s).Value)) Then
        '    DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & " * 1)"
        'Else
        '    DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & ")"
        'End If
     Next j
     For j = 0 To iColCount - 1
        'copy formula for first row of data
       tmpCell1s = GetColumn(SourceDataCol + j) & StartRow + 2
       tmpCell1d = GetColumn(Asc(StartCol) + j - Asc("A") + 1) & StartRow + 2
       'DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & ")"
       'DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",IF (IsNumeric(DATA!" & tmpCell1s & "),(DATA!" & tmpCell1s & ") * 1, DATA!" & tmpCell1s & "))"
        '################# WAS WITH *1 in the end... Yakir, 21/12/2011
        'DestWS.Range(tmpCell1d).Formula = "=IF(IsADate(DATA!" & tmpCell1s & "),DATA!" & tmpCell1s & ",(IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & " " & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "*1))))"
        DestWS.Range(tmpCell1d).Formula = "=IF(IsADate(DATA!" & tmpCell1s & "),DATA!" & tmpCell1s & ",(IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & " " & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "))))"
        ''DestWS.Range(tmpCell1d).Formula = "=IF(IsNumber(DATA!" & tmpCell1s & ")," & Chr(34) & "0" & Chr(34) & ",IF(ISERROR(DATA!" & tmpCell1s & "*1), DATA!" & tmpCell1s & ", DATA!" & tmpCell1s & "*1))"
        'If IsNumeric(CStr(SourceWS.Range(tmpCell1s).Value)) Then
        '    DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & " * 1)"
        'Else
        '    DestWS.Range(tmpCell1d).Formula = "=IF(DATA!" & tmpCell1s & "=" & Chr(34) & Chr(34) & "," & Chr(34) & " " & Chr(34) & ",DATA!" & tmpCell1s & ")"
        'End If
     Next j
     TotalsRange = StartCol & "3:" & EndCol & 3
     DestWS.Range(TotalsRange).Select
     DestWS.Range(TotalsRange).Copy
     'copy all colimns (row) from first to next rows
     For i = StartRow + 1 To RowCount
        tmpCell1 = StartCol & i + 1
        DestWS.Range(tmpCell1).Select
        DestWS.Paste
     Next i
Else
   EndRow = StartRow
End If


    Range("A3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Sheets("Pivot").Select
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "PRINT!R2C1:R7C12").CreatePivotTable _
        TableDestination:="Pivot!R3C1", TableName:="PivotTable1"
    Sheets("Print").Select
    Range("A3").Select
ErrAddRowsSummary:
End Sub


Public Sub DisplayPrint(Optional CP As Long = 1)
On Error GoTo ErrDisplayPrint


Dim PrintWS As Excel.Worksheet


Call AddRowsSummary


Set PrintWS = Application.ActiveWorkbook.Sheets("PRINT")


    'ActiveSheet.PageSetup.Orientation = xlLandscape
    'PrintWS.PrintOut , , CP
    'Application.ActiveWorkbook.Close False
    
ErrDisplayPrint:
End Sub


Public Function GetColumn(ByVal ColNum As Long) As String
On Error GoTo err_GetColumn


Dim NumTemp As Long, Remind As Long


NumTemp = ColNum \ 26
Remind = ColNum Mod 26
If Remind = 0 Then
    Remind = Remind + 26
    NumTemp = NumTemp - 1
End If
Select Case NumTemp
    Case 0
        GetColumn = Chr(Asc("A") + Remind - 1)
    Case 1
        GetColumn = "A" + Chr(Asc("A") + Remind - 1)
    Case 2
        GetColumn = "B" + Chr(Asc("A") + Remind - 1)
    Case 3
        GetColumn = "C" + Chr(Asc("A") + Remind - 1)
    Case 4
        GetColumn = "D" + Chr(Asc("A") + Remind - 1)
    Case 5
        GetColumn = "E" + Chr(Asc("A") + Remind - 1)
    Case 6
        GetColumn = "F" + Chr(Asc("A") + Remind - 1)
    Case 7
        GetColumn = "G" + Chr(Asc("A") + Remind - 1)
    Case 8
        GetColumn = "H" + Chr(Asc("A") + Remind - 1)
    Case 9
        GetColumn = "I" + Chr(Asc("A") + Remind - 1)
    Case Else


End Select






err_GetColumn:
End Function


Function IsADate(cel As Range) As Boolean
    If IsDate(cel) Then IsADate = True
End Function
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
One thing that pops out to me is that you have declared a variable i as Integer, and you are using that on rows.
Integers only go up to 32767. So if you have 60000 rows, you have to use a different variable type for i, like Long.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Need to add _AfterUpdate events to a dynamically-created class
Replies
1
Views
920
Matrovsky
M
D
  • Question
QRCode Generator
Replies
1
Views
1K
drag1c
D
Guna13
  • Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
775
Guna13
Guna13
P
  • Question
The cell or chart you're trying to change is on a protected sheet. Error upon placing worksheet Change Selection Code
Replies
1
Views
4K
pingme89
P
T
  • Question
Insert/Delete Columns issue via VBA
Replies
1
Views
679
Tdorman
T

Forum statistics

Threads
1,216,082
Messages
6,128,702
Members
449,464
Latest member
againofsoul

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top