Issue with VB Script within Excel - Run-time error 6: Overflow

spongebob

spongebob

Board Regular
Joined
Oct 25, 2004
Messages
68
Office Version
  1. 2019
Platform
  1. Windows
Hello All,

Running a nice script written a long time ago by MrExcel team, but suddenly hitting a speed bump.
My guess is there may be too many rows within a range causing the issue.
It's a complex script so its difficult to explain and data has too much sensitive information to share.

My question will be a general type of question which can maybe give me some insight.
I do understand some basic coding (linux) so this is not my area of expertise or experience... any ideas would be appreciated.

There highlighted row in the code is this one:

If Rng.Cells.Count > 1 Then

A snipit of that code is:
VBA Code: 
Private Sub PopulateNow(wsSource As Worksheet, wsTarget As Worksheet, SearchString As String, Marker As String, RowNumber As Long, Optional FormulaIndicator As String)
Dim Rng As Range
Dim rw As Long, GapRow As Long, OrigGapRow As Long
If FormulaIndicator = "T" Then
    GapRow = 2
    OrigGapRow = 2
Else
    GapRow = 3
    OrigGapRow = 3
End If
If wsTarget.Cells(wsTarget.Range(Marker).Row + GapRow, 1).Value <> "" Then GapRow = wsTarget.Range("A" & wsTarget.Range(Marker).Row + GapRow).End(xlDown).Row + 1 - wsTarget.Range(Marker).Row
wsSource.UsedRange.AutoFilter
wsSource.UsedRange.AutoFilter Field:=9, Criteria1:="=" & SearchString
Set Rng = wsSource.Range("A2", wsSource.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
If Rng.Cells.Count > 1 Then
    wsTarget.Activate
    wsTarget.Rows("" & wsTarget.Range(Marker).Row + GapRow & ":" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count - 1).Select
    Selection.EntireRow.Insert shift:=xlDown
    wsSource.Range("A2", wsSource.Range("G" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
    wsTarget.Activate
    Range(Marker).Offset(GapRow, 0).PasteSpecial xlPasteValuesAndNumberFormats
 
Sort by date Sort by votes
In looking at the entire code, I think it's ok to share it here....
This may make it easier to understand where the issue may be stemming from.
There error happened in the process step.



VBA Code: 
Option Explicit
'Customized solution written by Excel Guru; reach out to xl2vba@gmail.com for any support or assistance
Sub Process()
Dim j As Long, k As Long, l As Long
Dim timestart As String
timestart = Application.WorksheetFunction.Text(Now(), "hh:mm:ss")
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For j = 2 To LastRow(Sheets("Mapping_DB"), "A")
If IsError(Sheets("Mapping_DB").Cells(j, 1).Value) = True Then
    Sheets("Mapping_DB").Cells(j, 3).Value = "Error"
ElseIf Sheets("Mapping_DB").Cells(j, 1).Value <> "" Then
    If WorksheetExists(Sheets("Mapping_DB").Cells(j, 2).Value) = True Then
    'On Error Resume Next
        Call PopulateNow(Sheets("IN"), Sheets("" & Sheets("Mapping_DB").Cells(j, 2).Value), "" & Sheets("Mapping_DB").Cells(j, 1).Value, "Incoming", 23)
        Call PopulateNow(Sheets("Out"), Sheets("" & Sheets("Mapping_DB").Cells(j, 2).Value), "" & Sheets("Mapping_DB").Cells(j, 1).Value, "Outgoing", 24)
        Call PopulateNow(Sheets("Int"), Sheets("" & Sheets("Mapping_DB").Cells(j, 2).Value), "" & Sheets("Mapping_DB").Cells(j, 1).Value, "LD", 24, "L")
        Call PopulateNow(Sheets("Toll"), Sheets("" & Sheets("Mapping_DB").Cells(j, 2).Value), "" & Sheets("Mapping_DB").Cells(j, 1).Value, "TollFree", 24, "T")
        Call PopulateNow(Sheets("FAX"), Sheets("" & Sheets("Mapping_DB").Cells(j, 2).Value), "" & Sheets("Mapping_DB").Cells(j, 1).Value, "Fax", 25)
    'On Error GoTo 0
    Else
        Sheets("Mapping_DB").Cells(j, 3).Value = "Check"
    End If
End If
Next j
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
MsgBox "Done, started at " & timestart & vbCrLf & "Completed at " & Application.WorksheetFunction.Text(Now(), "hh:mm:ss")
End Sub
Private Sub PopulateNow(wsSource As Worksheet, wsTarget As Worksheet, SearchString As String, Marker As String, RowNumber As Long, Optional FormulaIndicator As String)
Dim Rng As Range
Dim rw As Long, GapRow As Long, OrigGapRow As Long
If FormulaIndicator = "T" Then
    GapRow = 2
    OrigGapRow = 2
Else
    GapRow = 3
    OrigGapRow = 3
End If
If wsTarget.Cells(wsTarget.Range(Marker).Row + GapRow, 1).Value <> "" Then GapRow = wsTarget.Range("A" & wsTarget.Range(Marker).Row + GapRow).End(xlDown).Row + 1 - wsTarget.Range(Marker).Row
wsSource.UsedRange.AutoFilter
wsSource.UsedRange.AutoFilter Field:=9, Criteria1:="=" & SearchString
Set Rng = wsSource.Range("A2", wsSource.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
If Rng.Cells.Count > 1 Then
    wsTarget.Activate
    wsTarget.Rows("" & wsTarget.Range(Marker).Row + GapRow & ":" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count - 1).Select
    Selection.EntireRow.Insert shift:=xlDown
    wsSource.Range("A2", wsSource.Range("G" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
    wsTarget.Activate
    Range(Marker).Offset(GapRow, 0).PasteSpecial xlPasteValuesAndNumberFormats
    For rw = (wsTarget.Range(Marker).Row + GapRow) To (wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count - 1)
        If FormulaIndicator = "L" Then
            Range("H" & rw).Formula = "=IF($F" & rw & "<$C$" & RowNumber & ",(D" & rw & "/60)*($C$" & RowNumber & "*1.3),(D" & rw & "/60)*(($F" & rw & "*$M$4) +F" & rw & "))"
        ElseIf FormulaIndicator = "T" Then
            Range("H" & rw).Formula = "=IF(E" & rw & "=""Toll-Free:Canada"",D" & rw & "/60*($M$6),IF(E" & rw & "=""Toll-Free:Alaska"",D" & rw & "/60*($M$7),IF(E" & rw & "=""Toll-Free:Puerto Rico"",D" & rw & "/60*($M$8),D" & rw & "/60*($M$5))))"
        Else
            Range("H" & rw).Formula = "=D" & rw & "/60*$C$" & RowNumber
        End If
    Next rw
    'Check if more than 1 blank rows are there below & delete them
    If wsTarget.Range("A" & (wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count) + 1).Value = "" Then
        Rows("" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count & ":" & Range("A" & (wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count)).End(xlDown).Row - 2).Select
        Selection.EntireRow.Delete
    End If
    Rows(wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count).Copy
    Range("A" & wsTarget.Range(Marker).Row + GapRow & ":H" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count).PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
    Range("C" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count + 1).Formula = "=COUNT(D" & wsTarget.Range(Marker).Row + OrigGapRow & ":D" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count & ")"
    Range("D" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count + 1).Formula = "=SUM(D" & wsTarget.Range(Marker).Row + OrigGapRow & ":D" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count & ")/60"
    Range("F" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count + 1).Formula = "=AVERAGE(F" & wsTarget.Range(Marker).Row + OrigGapRow & ":F" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count & ")"
    Range("G" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count + 1).Formula = "=ROUND(SUM(G" & wsTarget.Range(Marker).Row + OrigGapRow & ":G" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count & "),2)"
    Range("H" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count + 1).Formula = "=ROUND(SUM(H" & wsTarget.Range(Marker).Row + OrigGapRow & ":H" & wsTarget.Range(Marker).Row + GapRow + Rng.Cells.Count & "),2)"
End If
Sheets("Mapping_DB").Activate
End Sub
Sub SetupMasters()
Dim i As Long
Dim cell As Range
Dim timestartm As String
timestartm = Application.WorksheetFunction.Text(Now(), "hh:mm:ss")
On Error Resume Next
Application.ScreenUpdating = False
Sheets("Mapping_DB").Range("Sheet_Names").Clear
For i = 2 To Application.Sheets.Count
    Sheets("Mapping_DB").Range("D" & i) = Application.Sheets(i).Name
Next
ActiveWorkbook.Names("Sheet_Names").RefersTo = Sheets("Mapping_DB").Range("D2:D" & LastRow(Sheets("Mapping_DB"), "D"))
With Sheets("Mapping_DB")
    .Range("A2:B" & .UsedRange.Rows.Count).Clear
    Sheets("IN").Range("I2:I" & LastRow(Sheets("IN"))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Mapping_DB").Range("A" & LastRow(Sheets("Mapping_DB"), "A") + 1), Unique:=True
    Sheets("OUT").Range("I2:I" & LastRow(Sheets("OUT"))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Mapping_DB").Range("A" & LastRow(Sheets("Mapping_DB"), "A") + 1), Unique:=True
    Sheets("FAX").Range("I2:I" & LastRow(Sheets("FAX"))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Mapping_DB").Range("A" & LastRow(Sheets("Mapping_DB"), "A") + 1), Unique:=True
    Sheets("Int").Range("I2:I" & LastRow(Sheets("Int"))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Mapping_DB").Range("A" & LastRow(Sheets("Mapping_DB"), "A") + 1), Unique:=True
    Sheets("Toll").Range("I2:I" & LastRow(Sheets("Toll"))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Mapping_DB").Range("A" & LastRow(Sheets("Mapping_DB"), "A") + 1), Unique:=True
    .Range("A1:A" & LastRow(Sheets("Mapping_DB"), "A")).RemoveDuplicates Columns:=1, Header:=xlYes
    For Each cell In .Range("A2:A" & LastRow(Sheets("Mapping_DB"), "A"))
        cell.Offset(0, 1).Validation.Delete
        cell.Offset(0, 1).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Sheet_Names"
        cell.Offset(0, 1).Formula = "=iferror(vlookup(" & cell.Address & ",F:G,2,0),0)"
    Next cell
End With
Application.ScreenUpdating = True
MsgBox "Done, started at " & timestartm & vbCrLf & "Completed at " & Application.WorksheetFunction.Text(Now(), "hh:mm:ss")
End Sub
Function LastRow(ws As Worksheet, Optional ColName As String) As Long
If ColName = "" Then
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Else
LastRow = ws.Range("" & ColName & Rows.Count).End(xlUp).Row
End If
End Function
Function WorksheetExists(ByVal WorksheetName As String) As Boolean
Dim Sht As Worksheet
    For Each Sht In ThisWorkbook.Worksheets
        If Application.Proper(Sht.Name) = Application.Proper(WorksheetName) Then
            WorksheetExists = True
            Exit Function
        End If
    Next Sht
WorksheetExists = False
End Function

Private Sub InvoicePdf(ws As Worksheet, CoName As String, SerPeriod As String)
Dim tempstring As String
If Right(ThisWorkbook.Sheets("Mapping_DB").Range("fname").Value, 1) = "\" Then
    tempstring = ThisWorkbook.Sheets("Mapping_DB").Range("fname").Value & CoName & "-" & Replace(SerPeriod, "/", "-") & ".PDF"
Else
    tempstring = ThisWorkbook.Sheets("Mapping_DB").Range("fname").Value & "\" & CoName & "-" & Replace(SerPeriod, "/", "-") & ".PDF"
End If
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=tempstring, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
ws.PrintOut From:=1, To:=1, Copies:=1, Preview:=False
End Sub
Sub PrintAllSheets()
Dim mySht As Worksheet
Dim timestartp As String
timestartp = Application.WorksheetFunction.Text(Now(), "hh:mm:ss")
For Each mySht In ThisWorkbook.Worksheets
    With mySht
        If IsError(Application.Match(.Name, Sheets("Mapping_DB").Range("ExclTabs").Value, 0)) Then
            Call InvoicePdf(mySht, mySht.Range("B5").Value, mySht.Range("D2").Value)
        End If
    End With
Next mySht
MsgBox "Done, started at " & timestartp & vbCrLf & "Completed at " & Application.WorksheetFunction.Text(Now(), "hh:mm:ss")
End Sub
 
Upvote 0

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
That does not change the fact that you cannot reliably use autofilter when you do not have a header row.
 
Upvote 0
@Fluff Understood, adding a header row, will only work, if I also then add the header info in the code right?
I can force a header row on line 1.
 
Upvote 0
As I have no idea what the entire code is doing, I cannot really comment.
 
Upvote 0
I believe managed to find the reason behind the overflow problem. I apologize in advance if some else has written it before, but I don't have the time now to read the whole thread.
When you have a single cell range and you use the SpecialCells(xlCellTypeVisible) method on it then the resulting range contains all visible cells on the worksheet. Then using count produces the RTE 6, Overflow, because the number of cells is larger than the Long data type limit.
Normally if you have no visible cells in a range consisting of two or more cells, you will get RTE 1004 - No cells were found.
But if you have a 1 cell range, do not use .SpecialCells on it, or if you do - keep in mind what the result will be.
 
Upvote 0
You must log in or register to reply here.

Similar threads

spongebob
  • Question
Printing Function Stopped working
Replies
5
Views
454
spongebob
spongebob
A
  • Question
VBA Run-time error '52' : Bad file name or number - save file on Sharepoint
Replies
7
Views
6K
alantse2010
A
J
  • Question
Loop in outlook adding more attachments than intended - Outlook VBA Excel
Replies
7
Views
2K
RoryA
RoryA
J
  • Question
How can I unite these two scripts to send emails with single or multiple attachments to a list of contacts?
Replies
8
Views
1K
JorgeMartinez
J
G
  • Question
Excel VBA Macro steps through ok but when run it causes duplication
Replies
2
Views
3K
Gassy
G

Forum statistics

Threads
1,216,104
Messages
6,128,856
Members
449,472
Latest member
ebc9

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