We help IT Professionals succeed at work.

Excel VBA: add values based on multiple columns v2

High Priority
50 Views
Last Modified: 2020-02-14
Hello experts,

The following procedure allows me to add values on multiple filled columns:

Sub Add_Values_Multiple_Columns()

    Dim strCol As Variant
    Dim strColList As String
    Dim lngLastRow As Long, lngRow As Long
    Dim strToReplaceWith As String
    
    
    strToReplaceWith = InputBox("Please input the Value which should replace the values of the Reported Columns.")
    
    If strToReplaceWith = "" Then
        MsgBox "You didn't input any value.", vbExclamation
        Exit Sub
    End If
    

    strColList = InputBox("Please report column letter(s) following by ; in which you want to apply procedure," _
                          & ": A for single column A;C;D for multiple columns", "Choose Column Letter(s)")
    If strColList = vbNullString Then
        MsgBox ("No input!")
        Exit Sub
    End If
    
    For Each strCol In Split(strColList, ";")
        If Not ValidCellReference(strCol) Then
            MsgBox strCol & " is not a valid column letter.", vbExclamation
            Exit Sub
        Else
            lngRow = Range(strCol & Rows.Count).End(xlUp).Row
            If lngRow > lngLastRow Then lngLastRow = lngRow
        End If
    Next strCol
    
    For Each strCol In Split(strColList, ";")
        If lngLastRow > 1 Then Range(strCol & "2:" & strCol & lngLastRow).Value = strToReplaceWith
    Next

    Exit Sub

Error_Routine:
    MsgBox Err.Description, vbExclamation, "Something went wrong!"
    
End Sub

Function ValidCellReference(ByVal Str As String) As Boolean
Dim rng As Range
On Error Resume Next
Set rng = Cells(1, Str)
On Error GoTo 0
If Not rng Is Nothing Then ValidCellReference = True
End Function

Open in new window



I would like to take as a reference in order to cover the following need:
-Be able to repeat the values multiple time on selected column:

Example: If I report test for value to add column A and B for involved columns
I expect to have and inputbox with the following information: “How many times do you want to repeat the value to add?” If I report 4 I would have test test test test

I attached dummy file.

If you have questions, please contact me.

Thank you for your help.
Comment
Watch Question

Martin LissSocial distance - Don't touch your face - Wash your hands for 20 seconds
CERTIFIED EXPERT
Most Valuable Expert 2017
Distinguished Expert 2018

Commented:
You didn't upload the workbook.
Test your restores, not your backups...
CERTIFIED EXPERT
Expert of the Year 2019
Top Expert 2016
Commented:

Give this a try.


Option Explicit 
 
Sub Add_Values_Multiple_Columns() 
 
    Dim strCol As Variant 
    Dim strColList As String 
    Dim lngLastRow As Long, lngRow As Long 
    Dim strToReplaceWith As String 
    Dim strRepeat As String 
    Dim lngRepeat As Long 
    
    strToReplaceWith = InputBox("Please input the Value which should replace the values of the Reported Columns.") 
    If strToReplaceWith = "" Then 
        MsgBox "You didn't input any value.", vbExclamation 
        Exit Sub 
    End If 
 
    strRepeat = InputBox("How many times do you want to repeat the value to add?", "Specify Repeat Count") 
    If strRepeat = vbNullString Then 
        strRepeat = 1 
    Else 
        If IsNumeric(strRepeat) Then 
            lngRepeat = Abs(CLng(strRepeat)) 
        End If 
    End If 
 
    If lngRepeat > 1 Then 
        strToReplaceWith = RepeatString(lngRepeat, strToReplaceWith) 
    End If 
 
    strColList = InputBox("Please report column letter(s) following by ; in which you want to apply procedure," _ 
                          & ": A for single column A;C;D for multiple columns", "Choose Column Letter(s)") 
    If strColList = vbNullString Then 
        MsgBox ("No input!") 
        Exit Sub 
    End If 
 
    For Each strCol In Split(strColList, ";") 
        If Not ValidCellReference(strCol) Then 
            MsgBox strCol & " is not a valid column letter.", vbExclamation 
            Exit Sub 
        Else 
            lngRow = Range(strCol & Rows.Count).End(xlUp).Row 
            If lngRow > lngLastRow Then lngLastRow = lngRow 
        End If 
    Next strCol 
    
    For Each strCol In Split(strColList, ";") 
        If lngLastRow > 1 Then Range(strCol & "2:" & strCol & lngLastRow).Value = strToReplaceWith 
    Next 
 
    Exit Sub 
 
Error_Routine: 
    MsgBox Err.Description, vbExclamation, "Something went wrong!" 
    
End Sub 
 
Function ValidCellReference(ByVal Str As String) As Boolean 
    Dim rng As Range 
    On Error Resume Next 
    Set rng = Cells(1, Str) 
    On Error GoTo 0 
    If Not rng Is Nothing Then ValidCellReference = True 
End Function 
 
Function RepeatString(lngCount As Long, strValue As String) As String 
    Dim i As Long 
    RepeatString = "" 
    For i = 1 To lngCount 
        RepeatString = RepeatString & strValue & " " 
    Next 
    RepeatString = Trim(RepeatString) 
End Function

(EDIT: Adjusted to repeat the string one time rather than on each cell (thanks Subodh for the reminder))

Subodh Tiwari (Neeraj)Excel & VBA Expert
CERTIFIED EXPERT
Most Valuable Expert 2018
Awarded 2015
Commented:

You may try something like this...


Sub Add_Values_Multiple_Columns()

    Dim strCol As Variant
    Dim strColList As String
    Dim lngLastRow As Long, lngRow As Long
    Dim strToReplaceWith As String
    Dim cnt As Long
   
    strToReplaceWith = InputBox("Please input the Value which should replace the values of the Reported Columns.")
   
    cnt = Application.InputBox("How many times do you want to repeat the value to add?", Type:=1)
   
    strToReplaceWith = VBA.Trim(WorksheetFunction.Rept(strToReplaceWith & " ", cnt))
   
    If cnt = 0 Then
        MsgBox "You din't specify the number of times you want to repeat the value.", vbExclamation
        Exit Sub
    End If
   
    If strToReplaceWith = "" Then
        MsgBox "You didn't input any value.", vbExclamation
        Exit Sub
    End If
   

    strColList = InputBox("Please report column letter(s) following by ; in which you want to apply procedure," _
                          & ": A for single column A;C;D for multiple columns", "Choose Column Letter(s)")
    If strColList = vbNullString Then
        MsgBox ("No input!")
        Exit Sub
    End If
   
    For Each strCol In Split(strColList, ";")
        If Not ValidCellReference(strCol) Then
            MsgBox strCol & " is not a valid column letter.", vbExclamation
            Exit Sub
        Else
            lngRow = Range(strCol & Rows.Count).End(xlUp).Row
            If lngRow > lngLastRow Then lngLastRow = lngRow
        End If
    Next strCol
   
    For Each strCol In Split(strColList, ";")
        If lngLastRow > 1 Then Range(strCol & "2:" & strCol & lngLastRow).Value = strToReplaceWith
    Next

    Exit Sub

Error_Routine:
    MsgBox Err.Description, vbExclamation, "Something went wrong!"
   
End Sub

Function ValidCellReference(ByVal Str As String) As Boolean
Dim rng As Range
On Error Resume Next
Set rng = Cells(1, Str)
On Error GoTo 0
If Not rng Is Nothing Then ValidCellReference = True
End Function
Luis DiazIT consultant

Author

Commented:
Thank you very much. I will test the proposals and keep you informed.
Luis DiazIT consultant

Author

Commented:
I tested the proposals and they work.
I was wondering if the following adjustment can be done:
-If the column(s) reported in the inputbox 3 don't have any value as of row 2 exit sub with the following message:
"Unable to proceed as column(s) involved don't have values".
Thank you for your help.
Subodh Tiwari (Neeraj)Excel & VBA Expert
CERTIFIED EXPERT
Most Valuable Expert 2018
Awarded 2015
Commented:

Please give this a try...


Sub Add_Values_Multiple_Columns()

    Dim strCol              As Variant
    Dim strColList          As String
    Dim lngLastRow          As Long
    Dim lngRow              As Long
    Dim strToReplaceWith    As String
    Dim cnt                 As Long
    Dim EmptyCols           As Object
   
    strToReplaceWith = InputBox("Please input the Value which should replace the values of the Reported Columns.")
   
    cnt = Application.InputBox("How many times do you want to repeat the value to add?", Type:=1)
   
    strToReplaceWith = VBA.Trim(WorksheetFunction.Rept(strToReplaceWith & " ", cnt))
   
    If cnt = 0 Then
        MsgBox "You din't specify the number of times you want to repeat the value.", vbExclamation
        Exit Sub
    End If
   
    If strToReplaceWith = "" Then
        MsgBox "You didn't input any value.", vbExclamation
        Exit Sub
    End If
   
   
    strColList = InputBox("Please report column letter(s) following by ; in which you want to apply procedure," _
                          & ": A for single column A;C;D for multiple columns", "Choose Column Letter(s)")
    If strColList = vbNullString Then
        MsgBox ("No input!")
        Exit Sub
    End If
   
    Set EmptyCols = CreateObject("Scripting.Dictionary")
   
    For Each strCol In Split(strColList, ";")
        If Not ValidCellReference(strCol) Then
            MsgBox strCol & " is not a valid column letter.", vbExclamation
            Exit Sub
        Else
            lngRow = Range(strCol & Rows.Count).End(xlUp).Row
            If lngRow = 1 Then
                EmptyCols.Item(StrConv(strCol, vbUpperCase)) = ""
            Else
                If lngRow > lngLastRow Then lngLastRow = lngRow
            End If
        End If
    Next strCol
   
    For Each strCol In Split(strColList, ";")
        If Not EmptyCols.exists(StrConv(strCol, vbUpperCase)) Then
            Range(strCol & "2:" & strCol & lngLastRow).Value = strToReplaceWith
        End If
    Next
   
    If EmptyCols.Count > 0 Then
        MsgBox "The procedure skipped the empty columns " & Join(EmptyCols.keys, ", ") & "."
    End If
    Exit Sub

Error_Routine:
    MsgBox Err.Description, vbExclamation, "Something went wrong!"
   
End Sub

Function ValidCellReference(ByVal Str As String) As Boolean
Dim rng As Range
On Error Resume Next
Set rng = Cells(1, Str)
On Error GoTo 0
If Not rng Is Nothing Then ValidCellReference = True
End Function
Bill PrewTest your restores, not your backups...
CERTIFIED EXPERT
Expert of the Year 2019
Top Expert 2016
Commented:
Try this:

Option Explicit 
 
Sub Add_Values_Multiple_Columns() 
 
    Dim strCol As Variant 
    Dim strColList As String 
    Dim lngLastRow As Long, lngRow As Long 
    Dim strToReplaceWith As String 
    Dim strRepeat As String 
    Dim lngRepeat As Long 
    
    strToReplaceWith = InputBox("Please input the Value which should replace the values of the Reported Columns.") 
    If strToReplaceWith = "" Then 
        MsgBox "You didn't input any value.", vbExclamation 
        Exit Sub 
    End If 
 
    strRepeat = InputBox("How many times do you want to repeat the value to add?", "Specify Repeat Count") 
    If strRepeat = vbNullString Then 
        strRepeat = 1 
    Else 
        If IsNumeric(strRepeat) Then 
            lngRepeat = Abs(CLng(strRepeat)) 
        End If 
    End If 
 
    If lngRepeat > 1 Then 
        strToReplaceWith = RepeatString(lngRepeat, strToReplaceWith) 
    End If 
 
    strColList = InputBox("Please report column letter(s) following by ; in which you want to apply procedure," _ 
                          & ": A for single column A;C;D for multiple columns", "Choose Column Letter(s)") 
    If strColList = vbNullString Then 
        MsgBox ("No input!") 
        Exit Sub 
    End If 
 
    For Each strCol In Split(strColList, ";") 
        If Not ValidCellReference(strCol) Then 
            MsgBox strCol & " is not a valid column letter.", vbExclamation 
            Exit Sub 
        Else 
            lngRow = Range(strCol & Rows.Count).End(xlUp).Row 
            If lngRow > lngLastRow Then lngLastRow = lngRow 
        End If 
    Next strCol 

    If lngLastRow < 2 Then
        MsgBox "Unable to proceed as column(s) involved don't have values".
        Exit Sub
    End If

    For Each strCol In Split(strColList, ";") 
        If lngLastRow > 1 Then Range(strCol & "2:" & strCol & lngLastRow).Value = strToReplaceWith 
    Next 
 
    Exit Sub 
 
Error_Routine: 
    MsgBox Err.Description, vbExclamation, "Something went wrong!" 
    
End Sub 
 
Function ValidCellReference(ByVal Str As String) As Boolean 
    Dim rng As Range 
    On Error Resume Next 
    Set rng = Cells(1, Str) 
    On Error GoTo 0 
    If Not rng Is Nothing Then ValidCellReference = True 
End Function 
 
Function RepeatString(lngCount As Long, strValue As String) As String 
    Dim i As Long 
    RepeatString = "" 
    For i = 1 To lngCount 
        RepeatString = RepeatString & strValue & " " 
    Next 
    RepeatString = Trim(RepeatString) 
End Function

Open in new window


»bp
Luis DiazIT consultant

Author

Commented:
Thank you very much!
I tested the procedures and both works!
@Bill: just for the record, I modified line 49 of your proposal to make it work:
MsgBox "Unable to proceed as column(s) involved don't have values."

Regards,
Luis.
Bill PrewTest your restores, not your backups...
CERTIFIED EXPERT
Expert of the Year 2019
Top Expert 2016

Commented:
Whoops, I had just copied from your earlier comment to get the text, missed the period placement...


»bp
Luis DiazIT consultant

Author

Commented:
No problem Bill!