将string转换为大数据集中的数字

我目前正在使用这段代码将包含十进制数字的大量单元格转换为十进制数字：

For Each ws In Sheets On Error Resume Next For Each r In ws.UsedRange.SpecialCells(xlCellTypeConstants) If IsNumeric(r) Then r.Value = CDbl(r.Value) Next Next 

这个操作运行得很慢 ，如果可能的话，我希望它运行得更快。

我是一个初学者，上面显示的代码是通过谷歌收集的。 是否可以通过编辑代码或使用其他代码来使此操作更快？

Answer 1

根据您的内容，您可以使用快速保存一些处理

 For Each r In ws.UsedRange.SpecialCells(xlCellTypeConstants,xlTextValues) 

或者，将范围（或其中的一部分，如果真的很大）移动到数组中（使用myArray=range("b2:x200") ），然后处理该数组并立即重写。 这要快得多，因为在你的示例中，慢速部分实际上是VBA和单元之间的交互。

 Sub test() Dim src As Range Dim ar As Variant Dim r As Long, c As Long Set src = Range("b2").CurrentRegion ar = src 'move ange into array For r = 1 To UBound(ar, 1) For c = 1 To UBound(ar, 2) If VarType(ar(r, c)) = 8 Then 'string If IsNumeric(ar(r, c)) Then ar(r, c) = CDbl(ar(r, c)) End If End If Next c Next r src = ar 'write array back to sheet End Sub 

Answer 2

尝试这个。 这使用Array来完成整个操作。 与循环遍历每个范围相比，这是非常快的。

逻辑：

1. 循环浏览表格，find最后一行和最后一列
2. 识别范围，而不是盲目地使用UsedRange 。 你可能想看到这个
3. 将该数据复制到数组中
4. 清除表格 – 将表格的格式重置为General 。 希望你在表格中没有其他的格式？ 如果你有看到第二块代码。
5. 将数据粘贴回工作表。

码

 Sub Sample() Dim ws As Worksheet Dim usdRng As Range Dim lastrow As Long, lastcol As Long Dim myAr For Each ws In Sheets With ws '~~> Check if sheet has any data If Application.WorksheetFunction.CountA(.Cells) <> 0 Then '~~> Find Last Row lastrow = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row '~~> Find last column lastcol = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column '~~> Set your range here Set usdRng = .Range("A1:" & _ Split(.Cells(, lastcol).Address, "$")(1) & lastrow) '~~> Write to array myAr = usdRng.Value '~~> Clear the sheet .Cells.Clear '~~> Write back to the sheet .Range("A1").Resize(lastrow, lastcol).Value = myAr End If End With Next End Sub 

截图

编辑

如果你在表格中有其他格式，然后使用这个

 Sub Sample() Dim ws As Worksheet Dim usdRng As Range, rng as Range Dim lastrow As Long, lastcol As Long Dim myAr For Each ws In Sheets With ws '~~> Check if sheet has any data If Application.WorksheetFunction.CountA(.Cells) <> 0 Then '~~> Find Last Row lastrow = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row '~~> Find last column lastcol = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column '~~> Set your range here Set usdRng = .Range("A1:" & _ Split(.Cells(, lastcol).Address, "$")(1) & lastrow) On Error Resume Next Set rng = usdRng.SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not rng Is Nothing Then '~~> Write to array myAr = usdRng.Value '~~> Clear the Range rng.NumberFormat = "0.00" Set rng = Nothing '~~> Clear contents of the sheet usdRng.ClearContents '~~> Write back to the sheet .Range("A1").Resize(lastrow, lastcol).Value = myAr End If End If End With Next End Sub 

截图

Answer 3

另外两个选项，没有VBA：

1. 打开错误检查如果closures，select适当的范围，点击! ，点击转换为数字。

2. 在单元格中input1 ，select并复制它。 select合适的范围，select性粘贴…，操作乘。 （将空白单元格转换为0 。

Answer 4

closures和打开UI。

 'turn off UI Application.DisplayAlerts = False Application.ScreenUpdating = False Application.DisplayStatusBar = False Application.EnableEvents = False Application.Calculation = xlManual --- your code here 'turn on UI Application.DisplayAlerts = True Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True Application.Calculation = xlAutomatic 

Answer 5

我的版本 – 设置范围使用您的首选选项 – 我刚刚与UsedRange在这里，但最好使用FIND（Siddharths代码使用这个）。

我把数字1放到一个空白单元格中（我使用了表单中的最后一个单元格），复制该数字并粘贴特殊和相乘 – 任何数字将乘以1并返回一个数字，任何文本保持为

 Sub TurnToNumbers() Dim rng As Range With Worksheets("Sheet1") Set rng = .UsedRange.SpecialCells(xlCellTypeConstants) 'Place 1 into an empty cell, copy it and pastespecial and multiply. .Cells(Rows.Count, 1) = 1 .Cells(Rows.Count, 1).Copy rng.PasteSpecial Operation:=xlPasteSpecialOperationMultiply .Cells(Rows.Count, 1).ClearContents End With End Sub