Excel 处理二维数组以更正错误，然后用新数据替换单元格

我有一个模块，该模块应用代码清理unicode单元格，并替换为字典范围内的标准字母，我现在正尝试使用2D数组（第一次）来完成这一操作，然后在原始单元格中重新打印新的更正数组。我在Redim行中得到的类型下标超出了范围，在代码的后面可能还有其他错误，我还没有找到（unicode更正代码的工作方式与以前一样）。谢谢你的帮助

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

---

从

范围

获取数据到基于内存的数组比您想象的要简单得多。在你的情况下，我相信

Dim arr As Variant
arr = ActiveSheet.UsedRange.Value

这是所有需要的。根本不需要

Redim

。或者，考虑<代码> UsedRange < /代码>。因此，本例更能保证您得到想要的：

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

---

现在，每次需要确定数组的大小时，都应该使用

UBound

和

LBound

函数。

将数据从

范围

获取到基于内存的数组比您想象的要简单得多。在你的情况下，我相信

Dim arr As Variant
arr = ActiveSheet.UsedRange.Value

这是所有需要的。根本不需要

Redim

。或者，考虑<代码> UsedRange < /代码>。因此，本例更能保证您得到想要的：

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

现在，每次需要确定数组的大小时，都应该使用

UBound

和

LBound

函数。

清除范围内的值

选项显式
子Test2DArray（）
将wb设置为工作簿
将wb=ThisWorkbook设置为包含此代码的工作簿。
将ws设置为工作表
设置ws=wb.工作表（“表1”）
变暗rng As范围
设置rng=ws.UsedRange
作为变体的Dim-arr
arr=平均值
Dim xstr作为变体
我想我会坚持多久
Dim j尽可能长
长
作为字符串的Dim keepChrs
作为字符串的Dim ReadCode
将Unicode设置为字符串
将字母变暗为字符串
对于i=1至UBound（arr，1）
对于j=1至UBound（arr，2）
xstr=arr（i，j）
keepChrs=Left（xstr，0）
你说，这很有效。
对于n=1到Len（xstr）
如果（Mid（xstr，n，2））=“\u”，则
读码=（Mid（xstr，n，6））
CorrectUnicode=Replace（读码“\u”、“u+”）
NormalLetter=Mid（Application.WorksheetFunction.VLookup（正确的Unicode，工作表（“Unicode”）.Range（“A1:E1000”），5，False），2，1）
xstr=keepChrs&Replace（xstr，（Mid（xstr，n，6）），LCase（NormalLetter））
xstr=UCase（左（xstr，1））和Mid（xstr，2）
如果结束
下一个
arr（i，j）=xstr
下一个j
接下来我
rng.Value=arr
端接头

清除范围内的值

选项显式
子Test2DArray（）
将wb设置为工作簿
将wb=ThisWorkbook设置为包含此代码的工作簿。
将ws设置为工作表
设置ws=wb.工作表（“表1”）
变暗rng As范围
设置rng=ws.UsedRange
作为变体的Dim-arr
arr=平均值
Dim xstr作为变体
我想我会坚持多久
Dim j尽可能长
长
作为字符串的Dim keepChrs
作为字符串的Dim ReadCode
将Unicode设置为字符串
将字母变暗为字符串
对于i=1至UBound（arr，1）
对于j=1至UBound（arr，2）
xstr=arr（i，j）
keepChrs=Left（xstr，0）
你说，这很有效。
对于n=1到Len（xstr）
如果（Mid（xstr，n，2））=“\u”，则
读码=（Mid（xstr，n，6））
CorrectUnicode=Replace（读码“\u”、“u+”）
NormalLetter=Mid（Application.WorksheetFunction.VLookup（正确的Unicode，工作表（“Unicode”）.Range（“A1:E1000”），5，False），2，1）
xstr=keepChrs&Replace（xstr，（Mid（xstr，n，6）），LCase（NormalLetter））
xstr=UCase（左（xstr，1））和Mid（xstr，2）
如果结束
下一个
arr（i，j）=xstr
下一个j
接下来我
rng.Value=arr
端接头

VBASIC208的答案对于一小部分数据非常有效，但由于我有大量数据，我最终添加了一些额外的代码，将我使用的范围划分为多个部分，因此我在下面记下了最后的代码，以防其他人有一个大数据集。清理2.4亿个单元耗时210秒

我还添加了一个计时器和一条定时消息，以避免在处理大数据时出现“无响应”的情况，这两个消息显然都是可选的，但我已经包含了所有内容，以防有用：

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

---

VBASIC208的答案对于一小部分数据非常有效，但由于我有大量数据，我最终添加了一些额外的代码，将我使用的范围划分为多个部分，因此我在下面记下了最后的代码，以防其他人拥有大数据集。清理2.4亿个单元耗时210秒

我还添加了一个计时器和一条定时消息，以避免在处理大数据时出现“无响应”的情况，这两个消息显然都是可选的，但我已经包含了所有内容，以防有用：

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

---

如果使用Preserve关键字，则只能调整最后一个数组维度的大小，并且根本无法更改维度的数量

arr

是一个二维数组，您正试图将其更改为

1D

数组。从单元格填充的数组需要两个索引，例如

Dim arr（1到n，1到m）

，即使

m=1

。如果使用Preserve关键字，您只能调整最后一个数组维度的大小，并且根本无法更改维度的数量

arr

是一个2D数组，您正在尝试将其更改为

1D

数组。从单元格填充的数组需要两个索引，例如

Dim arr（1到n，1到m）

，即使

m=1

。请注意：复制时