UBound error - Subscript out of range

[Doug_James]

Hello:

I have a range of data that is dynamic. Rows and columns change in size all the time. I previously had the code to look only for Column O and update this column (delete certain characters). When I created this code I didn't realize Column O sometimes moves. It could be any column. So what I need to do now is look for the header name "BASIS" (originally known as Column O) and do the rest. While this is recognizing the correct column, when I get to Cells(r, (ColNum)) = arr(i - 1), I get the error "Subscript out of range".

Any help is appreciated, this is what I have so far:

Sub FormatBasis()

Dim SelRange As Range
Dim ColNum As Integer
Dim CWS As Worksheet, TmpWS As Worksheet

Set CWS = ActiveSheet
ColNum = Application.WorksheetFunction.Match("BASIS", CWS.Rows(1), 0)

Set SelRange = CWS.Columns(ColNum)

Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
       
Dim lr As Long
Dim r As Long
Dim arr() As String
Dim i As Long
   
    lr = Cells(Rows.Count, (ColNum)).End(xlUp).Row
   
    For r = 2 To lr
        If Cells(r, (ColNum)) <> "" Then
            arr = Split(Cells(r, (ColNum)), ";")
            'If Not IsEmpty(arr) Then
                i = UBound(arr)
                'End If
            Cells(r, (ColNum)) = arr(i - 1) 'HERE I'M GETTING STUCK
        End If
    Next r

End Sub

EDIT: Forgot to mention, Column "BASIS", sometimes is populated and some other times is blank

 

[Joe4]

Let's try adding in a few things, such as making sure that there is data (last row is greater than 1), and there is more than one object in your array (since you seem to want to pull the second from last value), i.e.

Sub FormatBasis()

Dim SelRange As Range
Dim ColNum As Integer
Dim CWS As Worksheet, TmpWS As Worksheet

Set CWS = ActiveSheet
ColNum = Application.WorksheetFunction.Match("BASIS", CWS.Rows(1), 0)

Set SelRange = CWS.Columns(ColNum)

Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
      
Dim lr As Long
Dim r As Long
Dim arr() As String
Dim i As Long
  
    lr = Cells(Rows.Count, (ColNum)).End(xlUp).Row

'   Exit sub if no data
    If lr < 2 Then Exit Sub

    For r = 2 To lr
        If Cells(r, (ColNum)) <> "" Then
            arr = Split(Cells(r, (ColNum)), ";")
            'If Not IsEmpty(arr) Then
                i = UBound(arr)
                'End If
            If i > 0 Then
                Cells(r, (ColNum)) = arr(i - 1)
            End If
        End If
    Next r

End Sub

 

[Doug_James]

Let's try adding in a few things, such as making sure that there is data (last row is greater than 1), and there is more than one object in your array (since you seem to want to pull the second from last value), i.e.

Sub FormatBasis()

Dim SelRange As Range
Dim ColNum As Integer
Dim CWS As Worksheet, TmpWS As Worksheet

Set CWS = ActiveSheet
ColNum = Application.WorksheetFunction.Match("BASIS", CWS.Rows(1), 0)

Set SelRange = CWS.Columns(ColNum)

Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
     
Dim lr As Long
Dim r As Long
Dim arr() As String
Dim i As Long
 
    lr = Cells(Rows.Count, (ColNum)).End(xlUp).Row

'   Exit sub if no data
    If lr < 2 Then Exit Sub

    For r = 2 To lr
        If Cells(r, (ColNum)) <> "" Then
            arr = Split(Cells(r, (ColNum)), ";")
            'If Not IsEmpty(arr) Then
                i = UBound(arr)
                'End If
            If i > 0 Then
                Cells(r, (ColNum)) = arr(i - 1)
            End If
        End If
    Next r

End Sub

Thanks Joe4, this works perfectly.

 

[Joe4]

You are welcome!
Glad I was able to help.