Excel VBA:特定の列の空白セルにテキストを追加してから、次の空白セルにループしてテキストを追加するにはどうすればよいですか?

Aug 22 2020

列Aの空白のセルにテキストを追加するマクロが必要です。マクロはテキストのあるセルをスキップする必要があります。マクロは、データセットの最後でループを停止する必要があります。

If Elseステートメントを使用しようとしていますが、間違った方向に進んでいると思います。私の現在の機能していないコードは以下のとおりです。どうもありがとうございました-私はまだVBAに不慣れです

Sub ElseIfi()

For i = 2 To 100

If Worksheets("RawPayrollDump").Cells(2, 1).Value = "" Then
Worksheets("RawPayrollDump").Cells(2, 1).Value = "Administration"

Else if(not(worksheets("RawPayrollDump").cells(2,1).value="")) then 'go to next cell

End If

Next

    
End Sub

回答

2 Mike67 Aug 22 2020 at 21:42

データの最後の行を見つけるには、End(xlUp)関数を使用します。

このコードを試してください。列Aのすべての空のセルを管理に置き換えます。

Sub ElseIfi()
    Set ws = Worksheets("RawPayrollDump")
    
    lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row ' last data row
        
    For i = 2 To lastrow  ' all rows until last data row
        If ws.Cells(i, 1).Value = "" Then  ' column A, check if blank
           ws.Cells(i, 1).Value = "Administration"  ' set text
        End If
    Next
End Sub
1 Variatus Aug 23 2020 at 00:33

ループする必要はありません。このコードを試してください。

Sub FillBlanks()

    Dim Rng         As Range
    
    With Worksheets("RawPayrollDump")
        Set Rng = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
    End With
    On Error Resume Next
    Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
    If Err Then
        MsgBox "There are no blank cells" & vbCr & _
               "in the specified range.", _
               vbInformation, "Range " & Rng.Address(0, 0)
    Else
        Rng.Value = "Administration"
    End If
End Sub
VBasic2008 Aug 23 2020 at 12:02

ブランクを交換するfeat。CurrentRegion

Range.CurrentRegion

  • OPが「...データセットの最後でループを停止する」と要求したので、私はこのCurrentRegionバージョンを作成しました。
  • 私が理解しているように、データセットの終わりは、列のデータを含む最後のセルの下に空白のセルが存在できないことを意味するものではありませんA
  • 1番目のサブを使用して2番目のメインサブ(replaceBlanks)をテストします。
  • 必要に応じて、ワークブック(1番目のサブ)を含む定数を調整します。
  • Criteria 文字列だけでなく他のデータ型を許可するためにVariantとして宣言されています。

コード

Option Explicit

Sub testReplaceBlanks()
    
    Const wsName As String = "RawPayrollDump"
    Const FirstCellAddress As String = "A2"
    Const Criteria As Variant = "Administration"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Call replaceBlanks(ws, FirstCellAddress, Criteria)
    
End Sub

Sub replaceBlanks(Sheet As Worksheet, _
                  FirstCellAddress As String, _
                  Criteria As Variant)
    
' Define column range.
    
    Dim ColumnRange As Range
    Set ColumnRange = Intersect(Sheet.Range(FirstCellAddress).CurrentRegion, _
                                Sheet.Columns(Sheet.Range(FirstCellAddress) _
                                                   .Column))
    ' To remove the possibly included cells above the first cell:
    Set ColumnRange = Sheet.Range(Range(FirstCellAddress), _
                                  ColumnRange.Cells(ColumnRange.Cells.Count))
    ' Note that you can also use the addresses instead of the cell range
    ' objects in the previous line...
    'Set ColumnRange = sheet.Range(FirstCellAddress, _
                                  ColumnRange.Cells(ColumnRange.Cells.Count) _
                                             .Address)
    ' or a mixture of them.
    
' Write values from column range to array.
    
    Dim Data As Variant
    If ColumnRange.Cells.Count > 1 Then
        Data = ColumnRange.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = ColumnRange.Value
    End If

' Modify array.
    
    Dim i As Long, k As Long
    For i = 1 To UBound(Data)
        If IsEmpty(Data(i, 1)) Then Data(i, 1) = Criteria: k = k + 1
    Next i
    
' Write modified array to column range.
    
    ' The following line is used when only the first cell is known...
    'Sheet.Range(FirstCellAddress).Resize(UBound(Data)).Value = Data
    ' ...but since the range is known and is the same size as the array,
    ' the following will do:
    ColumnRange.Value = Data
    
' Inform user.
    
    If k > 0 Then GoSub Success Else GoSub Fail
    
    Exit Sub
    
' Subroutines

Success:
    MsgBox "Wrote '" & Criteria & "' to " & k & " previously " _
         & "empty cell(s) in range '" & ColumnRange.Address & "'.", _
           vbInformation, "Success"
    Return
Fail:
    MsgBox "No empty cells in range '" & ColumnRange.Address & "'.", _
           vbExclamation, "Nothing Written"
    Return
           
End Sub