ืPlease help to simplify vba code with using For...Next

[btrth]

an idea project is to input numeric (such as 0,1, 4.5, 123.75, -2) in each cell (sheet1!d3:ac22)
and want to sent each input data cell (sheet1!d3:ac22) for accumulate in the sheet2 (sheet2!d3:ac22)
with the same table

my starting code are below...

Private Sub Worksheet_Change(ByVal target As Range)

Set d3sumrange = Range("d3")
bd3currentval = Range("Bd3").Value

If Not Intersect(target, [d3]) Is Nothing Then
    Range("Bd3").Value = Application.WorksheetFunction.Sum(bd3currentval, d3sumrange)
End If

End Sub

there are a number of text that i have to put with these vba code for run vba
how to rewrite the below code in short with using code For... Next?

Private Sub Worksheet_Change(ByVal target As Range)

Set d3sumrange = Range("d3")
Set d4sumrange = Range("d4")
Set d5sumrange = Range("d5")
...till Set ac22sumrange = Range("ac22")

bd3currentval = Range("Bd3").Value
bd4currentval = Range("Bd4").Value
bd5currentval = Range("Bd5").Value
...til bd22currentval = Range("Bd22").Value

If Not Intersect(target, [d3]) Is Nothing Then
    Range("Bd3").Value = Application.WorksheetFunction.Sum(bd3currentval, d3sumrange)
End If
If Not Intersect(target, [d4]) Is Nothing Then
   Range("Bd4").Value = Application.WorksheetFunction.Sum(bd4currentval, d4sumrange)
End If
If Not Intersect(target, [d5]) Is Nothing Then
   Range("Bd5").Value = Application.WorksheetFunction.Sum(bd5currentval, d5sumrange)
End If
...till If Not Intersect(target, [cc22]) Is Nothing Then           Range("cc22").Value = Application.WorksheetFunction.Sum(cc22currentval, cc22sumrange)
       End If

End Sub

your kindly advise is need. Thank you

 

[FormR]

want to sent each input data cell (sheet1!d3:ac22) for accumulate in the sheet2 (sheet2!d3:ac22)

Welcome to MrExcel!

If I understand correctly then maybe this will work for you.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, c As Range
Set r = Intersect(Target, Range("D3:AC22"))
If Not r Is Nothing Then
    For Each c In r
        With Sheets("Sheet2").Range(c.Address)
            If IsNumeric(.Value) And IsNumeric(c.Value) Then
                .Value = .Value + c.Value
            End If
        End With
    Next c
End If
End Sub

 

[ttdk1]

hope this help.

Private Sub Worksheet_Change(ByVal target As Range)


  If Not Intersect(target, Range("D3:AC22")) Is Nothing Then
    Worksheets("Sheet2").Cells(target.Row, target.Column).Value = Worksheets("Sheet2").Cells(target.Row, target.Column).Value + target.Value
  End If


End Sub

 

[btrth]

thank ttdk1 and FormR, both are hit my idea.

.................

may i ask for an additional favor?
continue with the above project....
i will got a weekly summary in sheet2.

i'm going to look for vb to clear range d3:ac22 after copy/add sheet2 (with existing data) to other workbook with create a new tab sheet name by current date of adding respectively



best regards,

 

[ttdk1]

Private Sub Worksheet_Change(ByVal target As Range)

  If Not Intersect(target, Range("D3:AC22")) Is Nothing Then
    Worksheets("Sheet2").Cells(target.Row, target.Column).Value = Worksheets("Sheet2").Cells(target.Row, target.Column).Value + target.Value
    dateStr = Replace(CStr(Date), "/", "-")
    
    dateFound = False
    
    For i = 1 To Sheets.Count
      If Sheets(i).Name = dateStr Then
         dateFound = True
         Exit For
      End If
    Next i
    
    If Not dateFound Then
      Sheets.Add After:=Worksheets(Worksheets.Count)
      Sheets(Sheets.Count).Name = dateStr
      Sheets("Sheet1").Select
    End If
    
    With Sheets(dateStr).Range("A" & Sheets(dateStr).Range("A" & Rows.Count).End(xlUp).Row + 1)
      .Value = Time
      .Offset(0, 1) = target.Value
      .Offset(0, 2) = target.Address
    End With
    
    Application.EnableEvents = False
    target.Value = ""
    Application.EnableEvents = True
  End If


End Sub

 

[FormR]

i'm going to look for vb to clear range d3:ac22 after copy/add sheet2 (with existing data) to other workbook with create a new tab sheet name by current date of adding respectively

Not sure if ttdk1 has answered your question already - but if not:

1) Are you asking for this to be part of the change event already suggested or a new procedure?
2) Does the "Other" workbook already exist?
3) If it does exist what is it's name and is it already open?

 

[FormR]

hope this help.

Private Sub Worksheet_Change(ByVal target As Range)


  If Not Intersect(target, Range("D3:AC22")) Is Nothing Then
    Worksheets("Sheet2").Cells(target.Row, target.Column).Value =  Worksheets("Sheet2").Cells(target.Row, target.Column).Value +  target.Value
  End If


End Sub

BTW - Try to copy a cell and paste it into a range with at least two cells, where one intersects the range D3:AC22..

 

[btrth]

thank for you time and sorry for my weak communication and late feed back.

i already got new solution to fulfill my above project.


best regards,