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の内部にある必要があります。

第2に、複数のIfの代わりにSelect Caseを使用できます。

第3に、Rangeには、,rr、rrrのように3つの異なるオブジェクトを持つ必要はありません。 cell0、cell1、およびcell5の場合も同じですが、rとcellのいずれか1つを使用できます。

If（Select Case）内の唯一の違いは、の範囲です。 r.Cellsをループする残りの部分は、3つのすべての基準で同じです。したがって、この部分をループの外側に置いて、1回だけ持つことができます。また

Modifedコード

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