I have two data range. 1st range is B4 to B18 and 2nd range are D3 to F7

and I am using below VBA code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range
If Application.Intersect(Target, Range("D3:F7")) Is Nothing Then GoTo check2:
For Each rngCell In Intersect(Target, Range("D3:F7"))
Application.EnableEvents = False

rngCell.Value = StrConv(rngCell, vbProperCase)

Range("B4").Value = Range("D3").Value
Range("B5").Value = Range("D4").Value
Range("B6").Value = Range("D5").Value
Range("B7").Value = Range("D6").Value
Range("B8").Value = Range("D7").Value
Range("B9").Value = Range("E3").Value
Range("B10").Value = Range("E4").Value
Range("B11").Value = Range("E5").Value
Range("B12").Value = Range("E6").Value
Range("B13").Value = Range("E7").Value
Range("B14").Value = Range("F3").Value
Range("B15").Value = Range("F4").Value
Range("B16").Value = Range("F5").Value
Range("B17").Value = Range("F6").Value
Range("B18").Value = Range("F7").Value
Application.EnableEvents = True

Next
check2:
End Sub

If I type anything in my second range, it should automatically update to my first range.

My problem is that, is there any short way to write this code. because in future I will increase my range area.

Please help.

I have two data range. 1st range is B4 to B18 and 2nd range are D3 to F7

and I am using below VBA code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range
If Application.Intersect(Target, Range("D3:F7")) Is Nothing Then GoTo check2:
For Each rngCell In Intersect(Target, Range("D3:F7"))
Application.EnableEvents = False

rngCell.Value = StrConv(rngCell, vbProperCase)

Range("B4").Value = Range("D3").Value
Range("B5").Value = Range("D4").Value
Range("B6").Value = Range("D5").Value
Range("B7").Value = Range("D6").Value
Range("B8").Value = Range("D7").Value
Range("B9").Value = Range("E3").Value
Range("B10").Value = Range("E4").Value
Range("B11").Value = Range("E5").Value
Range("B12").Value = Range("E6").Value
Range("B13").Value = Range("E7").Value
Range("B14").Value = Range("F3").Value
Range("B15").Value = Range("F4").Value
Range("B16").Value = Range("F5").Value
Range("B17").Value = Range("F6").Value
Range("B18").Value = Range("F7").Value
Application.EnableEvents = True

Next
check2:
End Sub

If I type anything in my second range, it should automatically update to my first range.

My problem is that, is there any short way to write this code. because in future I will increase my range area.

Please help.

• excel
• vba

• What is the logic behind the gaps in your first range? – CHill60 Commented Feb 3 at 13:02
• 2 What is the logic behind the choice of using VBA? You can just use a formula (like =D3 in cell "B4") for that. – Dominique Commented Feb 3 at 13:44
• 1 @Dominique It's more like =TOCOL(D3:F7,1,1) in MS365 but that doesn't convert the entered strings to proper case. – VBasic2008 Commented Feb 3 at 13:48
• The closest formula would be more like =LET(data,D3:F7,d,IF(data="","",PROPER(data)),TOCOL(d,,1)) assuming there are no errors. Putting the entered data in an Excel table and replacing the reference with e.g. Table1 would make it reasonably dynamic. – VBasic2008 Commented Feb 3 at 14:01

3 Answers 3

You can replace all of your Range("xx).Value = Range("yy").Value lines with just one line:

Cells(1 + rngCell.Row + (rngCell.Column - 4) * 5, 2) = rngCell.Value

This converts the co-ordinates of each target cell into a position on column B.

Making things a little more flexible as you mentioned changing the size of the range:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim TrgRng As Range
    Set TrgRng = Range("D3:F7") ' change F7 to suit
    
    If Application.Intersect(Target, TrgRng) Is Nothing Then GoTo check2:
    
    Dim rngCell As Range
    For Each rngCell In Intersect(Target, TrgRng)
        Application.EnableEvents = False
        rngCell.Value = StrConv(rngCell, vbProperCase)
        Cells(1 + rngCell.Row + (rngCell.Column - 4) * TrgRng.Rows.Count, 2) = rngCell.Value
        Application.EnableEvents = True
    Next
check2:
End Sub

A Worksheet Change: Convert and Copy

Private Sub Worksheet_Change(ByVal Target As Range)
    
    ' Define constants.
    Const SRC_RANGE_ADDRESS As String = "D3:F7"
    Const DST_FIRST_CELL_ADDRESS As String = "B4"
    
    ' Reference the source range.
    Dim srg As Range: Set srg = Me.Range(SRC_RANGE_ADDRESS)
    If Intersect(srg, Target) Is Nothing Then Exit Sub
    
    ' Return the values of the source range in the source array.
    Dim sRowsCount As Long: sRowsCount = srg.Rows.Count
    Dim sColumnsCount As Long: sColumnsCount = srg.Columns.Count
    Dim sData() As Variant: sData = srg.Value
    
    ' Define the destination array.
    Dim dRowsCount As Long: dRowsCount = sRowsCount * sColumnsCount
    Dim dData() As String: ReDim dData(1 To dRowsCount, 1 To 1)
    
    ' Declare additional variables.
    Dim sRow As Long, sCol As Long, dRow As Long, sString As String
    
    ' Read the strings from the source array and convert them as required
    ' updating the source array and populating the destination array.
    For sCol = 1 To sColumnsCount
        For sRow = 1 To sRowsCount
            dRow = dRow + 1
            sString = StrConv(CStr(sData(sRow, sCol)), vbProperCase)
            If Len(sString) > 0 Then
                sData(sRow, sCol) = sString
                dData(dRow, 1) = sString
            End If
        Next sRow
    Next sCol
    
    ' Write the updated strings to the ranges of the worksheet.
    Application.EnableEvents = False
        srg.Value = sData
        Dim drg As Range:
        Set drg = Me.Range(DST_FIRST_CELL_ADDRESS).Resize(dRowsCount)
        drg.Value = dData
    Application.EnableEvents = True
  
 End Sub

You can use the TOCOL function in Excel 365 or Excel 2021 to easily convert a range into a single column