How to fix "Run-time Error '9': Subscript out of Range"?

C

cs1810

New Member
Joined
May 5, 2015
Messages
14
Hi Everyone,

I have a script that is reformatting a dataset for me however i keep getting "Run-time Error '9': Subscript out of Range".

The guy who designed the code is no longer with the company so i'm attempting to spot fix the issue for the purpose of completing a project i'm working on.

It'd be great if i could get some help from you guys on this, i've pasted the code below. I highlighted the text red where the debugger picks up the issue.

Thanks,
Chris

Code: 
Sub ReformatGizmo()
Dim crtRow As Range
Dim crtColumn As Range
Dim crtPaste As Range
Dim segColumn As Range
Dim crtValue As Variant
Dim segValue As Variant
Dim crtItem As String
Dim nbSegments As Integer
Dim NbLines As Long
Dim crtPercil As Integer
Dim importSheet As Worksheet
Dim TimeStartedOffset As Integer
Dim ResponseIDOffset As Integer


Application.ScreenUpdating = False
Application.Calculation = xlManual


Set importSheet = ActiveSheet
[B][COLOR=#ff0000]Sheets("GizmoBis").UsedRange.Offset(1, 0).Delete[/COLOR][/B]


GoTo skipFormatting


'reformat UTF
Set myCell = Sheets("UTF").Range("A1")
Do While myCell <> ""
    importSheet.Cells.Replace What:=myCell, Replacement:=myCell.Offset(0, 1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
    Set myCell = myCell.Offset(1, 0)
    Loop


'gizom values starting with +/- signs are imported as formula => replace by apostrophe
On Error Resume Next
importSheet.UsedRange.Replace What:="=-", Replacement:="'-", LookAt:=xlPart
importSheet.UsedRange.Replace What:="=+", Replacement:="'+", LookAt:=xlPart
On Error GoTo 0


'Update Regions in Gizmo Data
A = Application.WorksheetFunction.Match("Region", importSheet.Range("1:1"), 0)
B = Application.WorksheetFunction.Match("Country", importSheet.Range("1:1"), 0)
C = Application.WorksheetFunction.Match("Subsidiary from URL", importSheet.Range("1:1"), 0)


On Error GoTo errCountryNotListed
Set myRange = Intersect(importSheet.Range("A:A"), importSheet.UsedRange)
Set myRange = myRange.Offset(1, 0).Resize(myRange.Rows.Count - 1, 1)
For Each myCell In myRange
    'If no Country, take Subsidiary
    If myCell.Offset(0, B - 1) = "" Then
        myCell.Offset(0, B - 1) = myCell.Offset(0, C - 1)
        End If
    If myCell.Offset(0, B - 1) <> "" And myCell.Row > 1 Then
        myCell.Offset(0, A - 1).Formula = Application.WorksheetFunction.VLookup(myCell.Offset(0, B - 1), Range("CountryRegion"), 2, 0)
        End If
    Next myCell


A = Application.WorksheetFunction.Match("Arkadin Region", importSheet.Range("1:1"), 0)
B = Application.WorksheetFunction.Match("Subsidiary from URL", importSheet.Range("1:1"), 0)
C = Application.WorksheetFunction.Match("Country", importSheet.Range("1:1"), 0)


For Each myCell In myRange
    'If no Subsidiary, take Country
    If myCell.Offset(0, B - 1) = "" Then
        myCell.Offset(0, B - 1) = myCell.Offset(0, C - 1)
        End If
    If myCell.Offset(0, B - 1) <> "" And myCell.Row > 1 Then
        myCell.Offset(0, A - 1).Formula = Application.WorksheetFunction.VLookup(myCell.Offset(0, B - 1), Range("CountryRegion"), 2, 0)
        End If
    Next myCell
On Error GoTo 0


skipFormatting:


Sheets("PercentDone").Visible = xlSheetVisible
Sheets("PercentDone").Activate
Sheets("PercentDone").Range("PercentDone").EntireRow.Interior.ColorIndex = 0
NbLines = Application.WorksheetFunction.CountA(importSheet.Range("A:A"))
crtPercil = 0
Sheets("PercentDone").Range("PercentDone").Select


'-------------START OF DATA IMPORT
Set crtPaste = Sheets("GizmoBis").Range("A2")
nbSegments = Application.WorksheetFunction.CountA(Sheets("GizmoBis").Range("1:1")) - 4 '4 value/data column
ResponseIDOffset = SegmentColumn("Response ID") - 1
TimeStartedOffset = SegmentColumn("Time Started") - 1


For Each crtRow In Range(importSheet.Range("A2"), importSheet.Range("A1").End(xlDown))


    ' display progress bar
    If (crtRow.Row / NbLines) >= (crtPercil / 40) Then
        Selection.Interior.ColorIndex = 1
        Selection.Offset(0, 1).Select
        crtPercil = crtPercil + 1
        Application.ScreenUpdating = True
        DoEvents
        Application.ScreenUpdating = False
        End If
    
    For Each crtColumn In Range(importSheet.Range("B1"), importSheet.Range("B1").End(xlToRight))
        crtValue = importSheet.Cells(crtRow.Row, crtColumn.Column)
        
        ' create line only if value and not a segment and not excluded label (underscore)
        If crtValue <> "" And SegmentColumn(crtColumn.Value) = 0 And Left(crtColumn.Value, 1) <> "_" Then
            crtPaste = crtRow
            
            ' get segments first
            If crtRow.Offset(0, ResponseIDOffset) <> crtPaste.Offset(-1, ResponseIDOffset) Then
                For Each segColumn In Range(importSheet.Range("B1"), importSheet.Range("B1").End(xlToRight))
                segValue = importSheet.Cells(crtRow.Row, segColumn.Column)
                    B = SegmentColumn(segColumn.Value)
                    If B > 0 Then
                        If segValue = "" Or Not (IsDate(segValue) Or IsNumeric(segValue)) Then
                            segValue = Right(segValue, Len(segValue) - InStrRev(segValue, ":"))
                            crtPaste.Offset(0, B - 1) = crtPaste.Offset(0, B - 1) _
                            & IIf(crtPaste.Offset(0, B - 1) = "", "", "|") _
                            & IIf(segValue = "", "<>", WorksheetFunction.Trim(segValue))
                            Else
                            crtPaste.Offset(0, B - 1) = segValue
                            End If
                        End If
                Next segColumn
            Else
                crtPaste.Offset(-1, 0).Resize(1, nbSegments).Copy (crtPaste.Resize(1, nbSegments))
            End If
            
            ' then get item/subitem
            A = InStrRev(crtColumn, ":")
            If A = 0 Then
                crtPaste.Offset(0, nbSegments) = crtColumn
            Else
                crtPaste.Offset(0, nbSegments) = Right(crtColumn, Len(crtColumn) - A)
                crtPaste.Offset(0, nbSegments + 1) = Left(crtColumn, A - 1)
            End If
            
            ' then get value and bucket
            crtPaste.Offset(0, nbSegments + 2) = crtValue
            If crtColumn = "Date Submitted" Then
                'Date Submitted becomes nb minutes to respond
                crtPaste.Offset(0, nbSegments + 3) = (crtValue - crtPaste.Offset(0, TimeStartedOffset)) * 1440
                Else
                crtPaste.Offset(0, nbSegments + 3) = crtValue
                End If
            Set crtPaste = crtPaste.Offset(1, 0)
            End If
    Next crtColumn
        
Next crtRow


' create Satisfaction promoters/demoters groups
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Very satisfied", Replacement:="Promoters", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Satisfied", Replacement:="Promoters", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Neither satisfied nor dissatisfied", Replacement:="Neutrals", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Dissatisfied", Replacement:="Detractors", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Very dissatisfied", Replacement:="Detractors", LookAt:=xlWhole


' create Satisfaction 1-5 scale
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Very satisfied", Replacement:="5", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Satisfied", Replacement:="4", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Neither satisfied nor dissatisfied", Replacement:="3", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Dissatisfied", Replacement:="2", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Very dissatisfied", Replacement:="1", LookAt:=xlWhole


' create Agreement promoters/demoters groups
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Strongly agree", Replacement:="Promoters", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Agree", Replacement:="Promoters", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Neither agree nor disagree", Replacement:="Neutrals", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Disagree", Replacement:="Detractors", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 3).Replace _
    What:="Strongly disagree", Replacement:="Detractors", LookAt:=xlWhole


' create Agreement 1-5 scale
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Strongly agree", Replacement:="5", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Agree", Replacement:="4", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Neither agree nor disagree", Replacement:="3", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Disagree", Replacement:="2", LookAt:=xlWhole
Sheets("GizmoBis").Range("A:A").Offset(0, nbSegments + 2).Replace _
    What:="Strongly disagree", Replacement:="1", LookAt:=xlWhole


A = Application.WorksheetFunction.Match("Administrators", Sheets("GizmoBis").Range("1:1"), 0) - 1
Sheets("GizmoBis").Range("A:A").Offset(0, A).Replace _
    What:="Please select if you have responsibility for buying or administrating collaboration solutions for your company." _
    , Replacement:="X", LookAt:=xlWhole


A = Application.WorksheetFunction.Match("Which of the following product(s) do you use?", Sheets("GizmoBis").Range("1:1"), 0) - 1
Sheets("GizmoBis").Range("A:A").Offset(0, A).Replace What:="|<>", Replacement:="", LookAt:=xlPart
Sheets("GizmoBis").Range("A:A").Offset(0, A).Replace What:="<>|", Replacement:="", LookAt:=xlPart




Sheets("GizmoBis").Range("A1").CurrentRegion.Name = "Gizmo"
importSheet.Range("A1").CurrentRegion.Name = "GizmoRaw"
Sheets("PercentDone").Visible = xlSheetHidden
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Exit Sub


errCountryNotListed:
Application.ScreenUpdating = True
Sheets("CountryRegion").Range("2:2").Insert
Sheets("CountryRegion").Range("A2").Formula = myCell.Offset(0, B - 1)
Sheets("CountryRegion").Range("B2").Formula = InputBox("Assign " & myCell.Offset(0, B - 1) & " to:", "Missing Country", "EMEA")
Application.ScreenUpdating = False
Resume


End Sub




Private Function SegmentColumn(Item As String) As Integer


Item = Right(Item, Len(Item) - InStrRev(Item, ":"))


On Error GoTo Not_a_segment
SegmentColumn = Application.WorksheetFunction.Match(Item, Sheets("GizmoBis").Range("1:1"), 0)
On Error GoTo 0
Exit Function


Not_a_segment:
SegmentColumn = 0
Resume Next


End Function




Private Function CountRespondents(Item As String) As Long
A = Application.WorksheetFunction.Match("Item", Sheets("GizmoBis").Range("1:1"), 0) - 1
crtID = 0
For Each myCell In Range("Gizmo").Resize(Range("Gizmo").Rows.Count, 1)
    If myCell.Offset(0, A) = Item And myCell <> crtID Then
        CountRespondents = CountRespondents + 1
        crtID = myCell
        End If
    Next
End Function


Private Function NPS(myRange As Range, Low As Integer, High As Integer) As Variant


If myRange.Columns.Count <> 11 Then Exit Function


p = Application.WorksheetFunction.Sum(myRange.Offset(0, High).Resize(1, 11 - High))
D = Application.WorksheetFunction.Sum(myRange.Resize(1, 1 + Low))
t = Application.WorksheetFunction.Sum(myRange)
'Debug.Print p, d, t
If t > 0 Then
    NPS = (p - D) / t * 100
    Else
    NPS = CVErr(xlErrNA)
    End If
    
End Function


Private Sub ChangeLabels()
xVals = ActiveChart.SeriesCollection(Selection.Name).Formula
    xVals = Right(xVals, Len(xVals) - InStr(1, xVals, ",", vbTextCompare))
    xVals = Left(xVals, InStr(1, xVals, ",", vbTextCompare) - 1)
    For Counter = 1 To Range(xVals).Cells.Count
    mylabel = Format(Range(xVals).Offset(0, -1).Cells(Counter), "0")
    With ActiveChart.SeriesCollection(Selection.Name).Points(Counter)
    .HasDataLabel = True
    .DataLabel.Text = mylabel
    '.DataLabel.Position = xlLabelPositionInsideEnd
    '.DataLabel.Top = .DataLabel.Top - 30
    End With
    Next
End Sub
 
Sort by date Sort by votes
Hi Morning everyone,

I added the Gizmobis tab manually as per Norie's suggestion but i'm still getting the same error. Looking at the debug tool it seems as if the error is coming from a different place though. I will attach a screen shot again. It looks as though as though there is a page with a progress bar that is causing the issue.

Capture2.jpg
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Have a look at your project window again. Do you see PercentDone inside any brackets?

You should mean
cs1810 said:
Hi Morning everyone,
It looks as though as though there isn't a page with a progress bar called "PercentDone". That is causing the issue.
Click to expand...
 
Last edited:
Upvote 0
Hi Mark, No i don't have that, but with this one i believe the code definitely generates the tab. However i don't know enough about coding to know where in the code this occurs.
 
Upvote 0
i believe the code definitely generates the tab.
Click to expand...

If it is not showing in the project window then the sheet does not exist. It doesn't matter if the sheets state is xlSheetVisible, xlSheetHidden or xlSheetVeryHidden, if a sheet exists it still appears there.

Important edit
It is used later in the below so you either create the sheet or comment out both bits.
Code: 
    ' display progress bar
    If (crtRow.Row / NbLines) >= (crtPercil / 40) Then
        Selection.Interior.ColorIndex = 1
        Selection.Offset(0, 1).Select
        crtPercil = crtPercil + 1
        Application.ScreenUpdating = True
        DoEvents
        Application.ScreenUpdating = False
        End If

I haven't looked further down the code.
 
Last edited:
Upvote 0
I did as you suggested and copied the percentdone tab from an older version of the file into this one and sure enough it starts. However as soon as it starts i get a new error now. I'll post both the error and the code below.

Capture3.jpg



Crop%203.jpg
 
Upvote 0
Afraid I don't want to go though the whole code debugging it when I can't see the sheets but
crtpaste is Sheets("GizmoBis").Range("A2")
from here
Code: 
crtPaste = Sheets("GizmoBis").Range("A2")

so you are looking at cell Sheets("GizmoBis").Range("A1") because of the Offset and the columns are being increased by the value of nbSegments
which is defined here...

Code: 
nbSegments = Application.WorksheetFunction.CountA(Sheets("GizmoBis").Range("1:1")) - 4 '4 value/data column
which is the number of cells used in row 1 of Sheets("GizmoBis") -4.

So if there are 10 columns used in row 1 of Sheets("GizmoBis") then
it reads as
Code: 
Sheets("GizmoBis").Range("A1:F1").Copy Sheets("GizmoBis").Range("A2:F2").
 
Last edited:
Upvote 0
Just to clarify I didn't suggest adding a sheet named 'GizmoBis'.:)
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA Macros running slow out of nowhere
Replies
3
Views
216
mumps
mumps
B
  • Question
Subscript Out of Range - Update Sheet Name (VBA)
2
Replies
10
Views
675
kevin9999
K
M
  • Question
search in worksheet for multiple words via userform
Replies
6
Views
335
Max01
M
S
  • Question
"Subscript out of range ( Run time Error: 09)" Problem in My Excel VBA
Replies
5
Views
272
6StringJazzer
6StringJazzer
S
  • Solved
Error due to missing date
Replies
3
Views
287
saracat2012
S

Forum statistics

Threads
1,215,056
Messages
6,122,907
Members
449,096
Latest member
dbomb1414

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