Working through a 2D Array to correct errors and then replace cells with new data

Question

I had a module that applied code to clean cells of unicode and replace with a standard letter from a dictionary range, I am trying to now do that by using a 2D array (for the first time) and then reprint the new corrected array back in the original cells. I am getting the type subscript out of range at Redim line, there maybe other errors further down the code I haven't got to yet (the unicode correction code works as used previously). Thanks for your help

Sub Test2DArray()
    Worksheets("Sheet1").Activate
    Dim arr As Variant, xstr
    arr = ActiveSheet.UsedRange
    Dim unicleanRWS As Variant, unicleanCLS

    For unicleanRWS = LBound(arr, 1) To UBound(arr, 1)
        For unicleanCLS = 1 To ActiveSheet.UsedRange.Rows.Count
            
            'Originally the above line was Lbound(arr,2) to ubound(arr,2) 
            'but I altered as I read I could not preserve both dimensions       

            ReDim Preserve arr(1 To UBound(arr, 1))

            xstr = arr(unicleanRWS, unicleanCLS)
            keepchrs = Left(xstr, 0)

            For I = 1 To Len(xstr)
                If (Mid(xstr, I, 2)) = "\u" Then
                    Readcode = (Mid(xstr, I, 6))
                    CorrectUnicode = Replace(Readcode, "\u", "U+")
                    NormalLetter = Mid(Application.WorksheetFunction.VLookup(CorrectUnicode, _
                        Worksheets("Unicode").Range("A1:E1000"), 5, False), 2, 1)
                    xstr = keepchrs & Replace(xstr, (Mid(xstr, I, 6)), LCase(NormalLetter))
                    xstr = UCase(Left(xstr, 1)) & Mid(xstr, 2)
                End If
            Next I

            arr(unicleanRWS, unicleanCLS) = xstr

        Next unicleanCLS
    Next unicleanRWS

    FirstCell = arr(0, 0).Address
    FirstCell.Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub

If you use the Preserve keyword, you can resize only the last array dimension and you can't change the number of dimensions at all. `arr` is a 2D array, and you are trying to change it to a `1D` array. — Ron Rosenfeld, Dec 10 '20 at 21:03
Array that populate from cell need two indices, like `Dim arr(1 to n, 1 to m)`, even if `m=1`. — JAlex, Dec 11 '20 at 14:08

PeterT · Answer 1 · 2020-12-10T21:20:05.907

1

Getting your data from a Range into a memory-based array is more straightforward than you're thinking. In your situation, I believe

Dim arr As Variant
arr = ActiveSheet.UsedRange.Value

is all that's required. There is no need for a Redim at all. Alternatively, consider that UsedRange can sometimes give different results. So this example is more of a guarantee to get exactly what you want:

Dim arr As Variant
Dim lastRow As Long
Dim lastCol As Long
With ActiveSheet
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Dim dataRange As Range
    Set dataRange = .Range("A1").Resize(lastRow, lastCol)
    arr = dataRange.Value
End With

Now, everytime you need to determine the size of the array, you should use the UBound and LBound functions.

edited Dec 10 '20 at 21:20

answered Dec 10 '20 at 21:08

PeterT

8,232
1
17
38

1

Just one remark: When copying data from a range and the range has only one cell, the result is not a 2-dimesional array but just a single value. Could happen for example when the code runs agains an empty sheet. – FunThomas Dec 10 '20 at 21:17
@FunThomas: Look at [this](https://stackoverflow.com/questions/65227228/using-vba-to-create-a-single-range-from-multiple-ranges/65227557#65227557) how Variatus determines if only one cell. – VBasic2008 Dec 10 '20 at 21:39
@VBasic2008: I perfectly know how to handle that. Just wanted to mention it because there are already numerous questions with exactly this problem. And I am still a little naive and hope that answers may help more that the OP. But those days seems to be gone – FunThomas Dec 10 '20 at 21:42
One additional issue has occured on my real data - my range is very large (apparantly its 9109569536 cells) which has now caused an out of memory error. Is there a simple way to slice my usedrange into sections so I can just loop through a sections? – TobyPython Dec 10 '20 at 22:39

score 1 · Accepted Answer · answered Dec 10 '20 at 21:33

Clean Values in Range

Option Explicit

Sub Test2DArray()

    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    Dim ws As Worksheet
    Set ws = wb.Worksheets("Sheet1")
    
    Dim rng As Range
    Set rng = ws.UsedRange
    
    Dim arr As Variant
    arr = rng.Value
    
    Dim xstr As Variant
    Dim i As Long
    Dim j As Long
    Dim n As Long
    
    Dim keepChrs As String
    Dim ReadCode As String
    Dim CorrectUnicode As String
    Dim NormalLetter As String
    
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            xstr = arr(i, j)
            keepChrs = Left(xstr, 0)
            
            ' This works well, you say.
            For n = 1 To Len(xstr)
                If (Mid(xstr, n, 2)) = "\u" Then
                    ReadCode = (Mid(xstr, n, 6))
                    CorrectUnicode = Replace(ReadCode, "\u", "U+")
                    NormalLetter = Mid(Application.WorksheetFunction.VLookup(CorrectUnicode, Worksheets("Unicode").Range("A1:E1000"), 5, False), 2, 1)
                    xstr = keepChrs & Replace(xstr, (Mid(xstr, n, 6)), LCase(NormalLetter))
                    xstr = UCase(Left(xstr, 1)) & Mid(xstr, 2)
                End If
            Next n
            
            arr(i, j) = xstr
        Next j
    Next i
    
    rng.Value = arr

End Sub

One additional issue has occured on my real data - my range is very large (apparantly its 9109569536 cells) which has now caused an out of memory error. Is there a simple way to slice my usedrange into sections so I can just loop through a sections? — TobyPython, Dec 10 '20 at 22:40

TobyPython · Answer 3 · 2020-12-11T16:20:23.210

VBasic2008's answer worked perfectly for a small set of data but because I had a large amount of data I ended up adding some extra code to break my used range into sections so I have noted the final code below in case anyone else has a large dataset. This took 210 seconds to cleanup 240m cells.

I added a timer as well, and a timed message to avoid a "Not responding" occurence I sometimes get with large data, both are obviously optional but I've included everything in case it is helpful:

Private Function MsgTimed(Message As String, Optional Seconds As Integer = 5, _
    Optional Title As String = "", Optional Options As Integer = 0)
'   Displays a message box for a predetermined duration then auto closes it.
'   Uses the same syntax as the built-in Popup function referenced on the page below...
'       http://msdn.microsoft.com/en-us/library/x83z1d9f%28v=vs.84%29.aspx
    CreateObject("WScript.Shell").Run "mshta.exe vbscript:close(CreateObject(""WScript.Shell"")" _
        & ".Popup(""" & Message & """," & Seconds & ",""" & Title & """," & Options & "))"
End Function
---------------
Sub TestArray()

    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    StartTime = Timer

    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    Dim ws As Worksheet
    Set ws = wb.Worksheets("Sheet1")
    
    ' Look up the usedrange and then break into 10 sections due to size
    Dim rng As Range, rng2, srng
    Set rng = ws.UsedRange
    Dim SectionsRng As Integer
    Dim SectionStart As Long, SectionEnd
    Dim MaxCol As String
    Dim arr As Variant
    Dim xstr As Variant
    Dim i As Long
    Dim j As Long
    Dim n As Long
    
    Dim keepChrs As String
    Dim ReadCode As String
    Dim CorrectUnicode As String
    Dim NormalLetter As String
       
    ' Create 50 sections of UsedRange to avoid Out of Memory error
    SectionStart = rng.Cells.Row
    SectionEnd = Round(rng.rows.Count / 50)
    MaxCol = Split(Cells(1, rng.Columns.Count).Address, "$")(1)
    
    For SectionsRng = 1 To 50
    If SectionsRng > 1 Then SectionStart = 1 + SectionEnd
    If SectionsRng > 1 Then SectionEnd = Round(SectionEnd / (SectionsRng - 1) * SectionsRng)
    srng = ("$A$" & SectionStart & ":$" & MaxCol & "$" & SectionEnd)
    
    Set rng2 = ws.Range(srng)
    Debug.Print rng2.Address
    
    ' Create array and process data
    
    arr = rng2.Value
       For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
             xstr = arr(i, j)
                     

            keepChrs = Left(xstr, 0)
            
                For n = 1 To Len(xstr)
                If (Mid(xstr, n, 2)) = "\u" Then
                    ReadCode = (Mid(xstr, n, 6))
                    CorrectUnicode = Replace(ReadCode, "\u", "U+")
                    NormalLetter = Mid(Application.WorksheetFunction.VLookup(CorrectUnicode, Worksheets("Unicode").Range("A1:E1000"), 5, False), 2, 1)
                    xstr = keepChrs & Replace(xstr, (Mid(xstr, n, 6)), LCase(NormalLetter))
                    xstr = UCase(Left(xstr, 1)) & Mid(xstr, 2)
                End If
            Next n
            
            arr(i, j) = xstr
        Next j
        Next i
    
   
    rng2.Value = arr

    ' MessageBox seems to stop Not responding occuring
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgTimed "Time " & SecondsElapsed & " Reached Row: " & SectionEnd, 3, "Alert", vbInformation
    
    Next SectionsRng
    
    'Print Timer in Immediate Window
    Debug.Print SecondsElapsed

End Sub

You can delete this answer if you chose to do so, but don't just vandalise it — Alon Eitan, Dec 11 '20 at 13:41
I had to go out for a while before I could edit and knowing how quickly people comment I took it off for a while. — TobyPython, Dec 11 '20 at 14:20

Working through a 2D Array to correct errors and then replace cells with new data

3 Answers3

Clean Values in Range