Excel VBA 跳过了很多事件

Question

我有一个 6 张工作簿。我正在使用 For Each 浏览它们。任务是： 1）遍历具有指定范围的每个单元格

2) 如果单元格不为空且仅包含数字，则在单元格末尾添加“мм”。否则跳过此单元格。

但实际上，脚本只对第一张工作表（工作表）有用。它不会更改其他工作表。我不知道为什么会这样。我认为，代码中存在一些错误或错误，但我仔细检查了它，一切似乎都是正确的。请帮帮我:)

Sub SaveWorksheetsAsCsv()
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Dim r As Range
Dim rr As Range
Dim rrrrrr As Range
Dim cell As Range
k = Cells(Rows.Count, "A").End(xlUp).Row
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)

For Each xWs In Application.ActiveWorkbook.Worksheets

    If xWs.Name Like "Worksheet" Then
        Set r = Range("FA2:FA" & k)
        For Each cell0 In r
            If IsEmpty(cell0.Value) = False And IsNumeric(cell0.Value) = True Then
                cell0.Value = cell0.Value & " мм"
            End If
        Next
        'xWs.Columns(41).EntireColumn.Delete
    End If

    If xWs.Name Like "Worksheet 1" Then
        Set rr = Range("AG2:AG" & k)
        For Each cell1 In rr
            If IsEmpty(cell1.Value) = False And IsNumeric(cell1.Value) Then

                cell1.Value = cell1.Value & " мм"

            End If
        Next
        'xWs.Columns(126).EntireColumn.Delete
    End If

    If xWs.Name Like "Worksheet 5" Then
        Set rrrrrr = Range("FR2:FR" & k)
        For Each cell5 In rrrrrr
            If IsEmpty(cell5.Value) = False And IsNumeric(cell5.Value) Then

                cell5.Value = cell5.Value & " мм"

            End If
        Next
    End If

    xWs.SaveAs xDir & "\" & xWs.Name, xlCSV, local:=True

Next
End Sub

Answer 1

需要调整这些语句集以更正工作表引用。当前代码将始终查看活动工作表，并且范围引用不合格。

Set r = Range("FA2:FA" & k)

Set r = xWs.Range("FA2:FA" & k)

Answer 2

您可以缩短并大量利用您的代码。

首先，您的 k = Cells(Rows.Count, "A").End(xlUp).Row 试图获取最后一行，需要在 For Each xWs In Application.ActiveWorkbook.Worksheets 内，因为每个工作表的最后一行都不同。

其次，你可以使用Select Case，而不是多个Ifs。

第三，Range 不需要有 3 个不同的对象，例如 r、rr 和 rrr。 cell0、cell1 和 cell5 也是如此，您可以只使用一个 r 和 cell。

在您的If（我的Select Case）中唯一不同的是您设置的r 范围。其余的循环 r.Cells 对于所有 3 个条件都是相同的，因此您可以将这部分放在循环之外，并且只使用一次。

修改后的代码

Option Explicit

Sub SaveWorksheetsAsCsv()

Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Dim r As Range
Dim cell As Range
Dim k As Long

Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)

For Each xWs In ThisWorkbook.Worksheets ' it's safer to use ThisWorkbook is you reffer to the worksheets inside the workbook which thid code resides
    With xWs
        ' getting the last row needs to be inside the loop
        k = .Cells(.rows.Count, "A").End(xlUp).Row

        Set r = Nothing ' reset Range Object

        Select Case .Name
            Case "Worksheet"
                Set r = .Range("FA2:FA" & k)
                'xWs.Columns(41).EntireColumn.Delete

            Case "Worksheet 1"
                Set r = .Range("AG2:AG" & k)
                'xWs.Columns(126).EntireColumn.Delete

            Case "Worksheet 5"
                Set r = .Range("FR2:FR" & k)

        End Select

        ' check if r is not nothing (it passed one of the 3 Cases in the above select case)
        If Not r Is Nothing Then
            For Each cell In r
                If IsEmpty(cell.Value) = False And IsNumeric(cell.Value) Then
                    cell.Value = cell.Value & " мм"
                End If
            Next cell
        End If

        .SaveAs xDir & "\" & .Name, xlCSV, Local:=True
    End With

Next xWs

End Sub