Is it possible to fill cells in a range with "x" if the number of filled cells in that col-CodePudding

In a sheet of my workbook I have range C8:C104 filled with values from another sheet of my workbook. These number of values can vary from 2 to 96 with no blank cells in between.

Before copying these values to a txt-file I need to auto fill blank cells in this column until the number of non blank cells in the range can be divided by 4.

Example:

C8:C12 contain data => no cells need to be auto filled

C8:C10 contain data => Cells C11 and C12 need to be filled with the text "x" (the rest of the cells in the range stay blank)

Normally Google is my best friend in situations like this, but unfortunately I could not find any Q&A similar to this. I got the part running to copy the cells and sending them as a txt.file by outlook mail, but have no clue how to get the auto fill part up and running yet. Is there anyone who can help me get started, am not very experienced and a bit rusty with my VBA skills?

CodePudding user response：

Return a Column in a String Conditionally

Adjust the values in the constants section.
Reference the worksheet more safely.

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Tests the 'StrFilledColumnRange' function.
' Calls:        StrFilledColumnRange, TextString.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub StrFilledColumnRangeTEST()
    
    ' Define constants.
    Const FilePath As String = "C:\Test\Test.txt"
    Const crgAddress As String = "C8:C104"
    Const FillString As String = "x"
    Const ModNonBlank As Long = 4
    Const HasHeader As Boolean = True

    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the (one-column) range ('crg').
    Dim crg As Range: Set crg = ws.Range(crgAddress)
    
    ' Using the function, return the required values in a string ('rString').
    Dim rString As String
    rString = StrFilledColumnRange(crg, FillString, ModNonBlank, True)
    
    ' Check if the string is empty.
    If Len(rString) = 0 Then
        MsgBox "The resulting string is empty.", vbExclamation
        Exit Sub
    End If

    ' Display the result.
    Debug.Print rString
    'MsgBox rString, vbInformation

    ' Write the string to a text file.
    'TextString FilePath, rString

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      From a given one-column range, returns a string that...
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrFilledColumnRange( _
    ByVal ColumnRange As Range, _
    ByVal FillString As String, _
    Optional ByVal ModNonBlank As Long = 1, _
    Optional ByVal HasHeader As Boolean = False) _
As String
    Const ProcName As String = "StrFilledColumnRange"
    On Error GoTo ClearError
    
    ' Reference the first cell ('fCell') of the range.
    Dim fCell As Range: Set fCell = ColumnRange.Cells(1)
    
    ' Reference the column data range ('cdrg')(no headers).
    Dim hrOffset As Long
    If HasHeader Then hrOffset = 1
    Dim cdrg As Range: Set cdrg = ColumnRange _
        .Resize(ColumnRange.Rows.Count - hrOffset).Offset(hrOffset)
    
    ' Make sure that all rows and columns are visible, or the following
    ' use of the Find method will fail.
    ' Reference the bottom-most non-blank cell ('lCell')
    ' of the column data range ('xlValues' - non-blanks).
    Dim lCell As Range: Set lCell = cdrg.Find("*", , xlValues, , , xlPrevious)
    If lCell Is Nothing Then
        MsgBox "No data in '" & cdrg.Address(0, 0) & "'.", vbCritical
        Exit Function
    End If
    
    ' Retrieve the current number of rows ('crCount') of the column data range.
    Dim crCount As Long: crCount = lCell.Row - fCell.Row - hrOffset   1
    
    ' Calculate the remainder ('Remainder'), the number of how many
    ' fill strings to be 'appended'.
    Dim Remainder As Long: Remainder = crCount Mod ModNonBlank
    If Remainder > 0 Then Remainder = ModNonBlank - Remainder
    
    ' Write the source number of rows to a variable ('srCount').
    Dim srCount As Long: srCount = ColumnRange.Rows.Count
    
    ' Calculate the destination number of rows ('drCount')
    ' and correct 'Remainder'.
    Dim drCount As Long: drCount = hrOffset   crCount   Remainder
    If drCount > srCount Then
        Remainder = Remainder   srCount - drCount
        drCount = srCount
    End If
    
    ' Declare a variable for the resulting string ('rString').
    Dim rString As String
    
    If drCount = 1 Then ' one cell only; unlikely yet theoretically possible
        rString = ColumnRange.Value
    Else ' multiple cells
        ' Reference the last (offsetted) cell.
        Set lCell = lCell.Offset(Remainder)
        ' Reference the range ('crg').
        Dim crg As Range: Set crg = ColumnRange.Worksheet.Range(fCell, lCell)
        ' Write the values from the range to a 2D one-based array ('cData').
        Dim cData() As Variant: cData = crg.Value
        ' Write the fill string(s) to the array.
        Dim dr As Long ' Current Destination Row
        For dr = drCount To drCount - Remainder   1 Step -1
            cData(dr, 1) = FillString
        Next dr
        ' Write the values from the array to the resulting string.
        rString = cData(1, 1)
        For dr = 2 To drCount
            rString = rString & vbLf & cData(dr, 1)
        Next dr
    End If
    
    ' Return the string as the result of the function.
    StrFilledColumnRange = rString
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes a string to a file.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub TextString( _
        ByVal FilePath As String, _
        ByVal WriteString As String)
    Const ProcName As String = "TextString"
    On Error GoTo ClearError
    
    Dim TextFile As Long: TextFile = FreeFile
    
    Open FilePath For Output Access Write As #TextFile
        Print #TextFile, WriteString
    Close TextFile
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

CodePudding user response：

The following will pad the cells with x until there are a multiple of 4 cells populated:

Sub pad_to_mod_4()

    Dim myrange As Range
    Dim ws As Worksheet

    padding = "x"
    
    Set ws = ActiveSheet                'set this to your worksheet
    Set myrange = ws.Range("C8:C104")
    
    Do Until myrange.Cells.SpecialCells(xlCellTypeConstants).Count Mod 4 = 0
        myrange(myrange.Count).End(xlUp).Offset(1, 0).Value = padding
    Loop
    
End Sub