Shortening VB Code

[VNouBA]

Shortening VB Code

Basically I need the following code to be shorten but to add itself to the next available row.

[vba]
If Target.Address = "$B$5" Then
If Sheets("Report").Range("J5") = "" Then
Sheets("Report").Range("J5") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "J").End(xlUp)(2).Value = Target.Value
End If
End If

If Target.Address = "$D$5" Then
If Sheets("Report").Range("L5") = "" Then
Sheets("Report").Range("L5") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "L").End(xlUp)(2).Value = Target.Value
End If
End If

If Target.Address = "$H$5" Then
If Sheets("Report").Range("M5") = "" Then
Sheets("Report").Range("M5") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "M").End(xlUp)(2).Value = Target.Value
End If
End If

If (Target.Address = "$I$5" Or Target.Address = "$J$5") And Target.Value <> "" Then
Range("I5,J5").Copy
If Sheets("Report").Range("N5").Value = "" Then
Sheets("Report").Range("N5").PasteSpecial xlPasteValues
Else
Sheets("Report").Cells(Rows.Count, "N").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If

If Target.Address = "$B$6" Then
If Sheets("Report").Range("J6") = "" Then
Sheets("Report").Range("J6") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "J").End(xlUp)(2).Value = Target.Value
End If
End If

If Target.Address = "$D$6" Then
If Sheets("Report").Range("L6") = "" Then
Sheets("Report").Range("L6") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "L").End(xlUp)(2).Value = Target.Value
End If
End If

If Target.Address = "$H$6" Then
If Sheets("Report").Range("M6") = "" Then
Sheets("Report").Range("M6") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "M").End(xlUp)(2).Value = Target.Value
End If
End If

If (Target.Address = "$I$6" Or Target.Address = "$J$6") And Target.Value <> "" Then
Range("I6,J6").Copy
If Sheets("Report").Range("N6").Value = "" Then
Sheets("Report").Range("N6").PasteSpecial xlPasteValues
Else
Sheets("Report").Cells(Rows.Count, "N").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If

If Target.Address = "$B$7" Then
If Sheets("Report").Range("J7") = "" Then
Sheets("Report").Range("J7") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "J").End(xlUp)(2).Value = Target.Value
End If
End If

If Target.Address = "$D$7" Then
If Sheets("Report").Range("L7") = "" Then
Sheets("Report").Range("L7") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "L").End(xlUp)(2).Value = Target.Value
End If
End If

If Target.Address = "$H$7" Then
If Sheets("Report").Range("M7") = "" Then
Sheets("Report").Range("M7") = Target.Value
Else
Sheets("Report").Cells(Rows.Count, "M").End(xlUp)(2).Value = Target.Value
End If
End If

If (Target.Address = "$I$7" Or Target.Address = "$J$7") And Target.Value <> "" Then
Range("I7,J7").Copy
If Sheets("Report").Range("N7").Value = "" Then
Sheets("Report").Range("N7").PasteSpecial xlPasteValues
Else
Sheets("Report").Cells(Rows.Count, "N").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
[/vba]

Does someone know a quick trick?


I am doing copy and paste right now on this code all the way to row 30 but might have to do more (until 100) this could take days if I modify any columns.


Thank you in advance

[Bob Phillips]

Untested

[VBA]If Target.Address = "$B$5" Then Call ActionChange(Target, "B", 6)

If Target.Address = "$D$5" Then Call ActionChange(Target, "D", 6)

If Target.Address = "$H$5" Then Call ActionChange(Target, "H", 6)

If (Target.Address = "$I$5" Or Target.Address = "$J$5") And Target.Value <> "" Then Call ActionChange2(Target, "N")

If Target.Address = "$B$6" Then Call ActionChange(Target, "J", 6)

If Target.Address = "$D$6" Then Call ActionChange(Target, "L", 6)

If Target.Address = "$H$6" Then Call ActionChange(Target, "M", 6)

If (Target.Address = "$I$6" Or Target.Address = "$J$6") And Target.Value <> "" Then Call ActionChange2(Target, "N")

If Target.Address = "$B$7" Then Call ActionChange(Target, "J")

If Target.Address = "$D$7" Then Call ActionChange(Target, "L")

If Target.Address = "$H$7" Then Call ActionChange(Target, "M")

If (Target.Address = "$I$7" Or Target.Address = "$J$7") And Target.Value <> "" Then Call ActionChange2(Target, "N")
End Sub

Private Function ActionChange(ByRef Target As Range, updatecol As String)
With Worksheets("Report")
If .Range(col & Target.Row) = "" Then
.Range(col & Target.Row) = Target.Value
Else
.Cells(Rows.Count, col).End(xlUp).Offset(1, 0).Value = Target.Value
End If
End If
End Function

Private Function ActionChange2(ByRef Target As Range, updatecol As String, updaterow As Long)
With Worksheets("Report")
Me.Cells(Target.Row, "I").Resize(, 2).Copy
If .Range(col & Target.Row) = "" Then
.Range(col & targetrow).PasteSpecial xlPasteValues
Else
.Cells(Rows.Count, col).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End Function
[/VBA]

[VNouBA]

xld thank you for your help... it kinda works but just found out my hole project just glitched and need to find a new approach for my Workbook "overall"

I will post all my Worksheets code in a seperate Thread...

[Kenneth Hobs]

For my method in a Module:
[VBA]Function ColumnLetter(ColumnNum As Long) As String
ColumnLetter = Replace(Cells(1, ColumnNum).Address(0, 0), 1, "")
End Function[/VBA]

In the Sheet's code:
[VBA]Private Sub Worksheet_Change(ByVal target As Range)
Dim iRange As Range, iCell As Range, tRow As Long, tCol As String
Dim rSheet As Worksheet, iCol As Long

If target.Cells.Count <> 1 Then Exit Sub

'Total Rows based on Column A data.
tRow = Range("A" & Rows.Count).End(xlUp).Row

Set iRange = Range("B5:B" & tRow & ",D5" & tRow & ",H5:H" & tRow & _
",I5:I" & tRow & ",J5:J" & tRow)
Set iCell = Intersect(iRange, target)
If iCell Is Nothing Then Exit Sub

Application.EnableEvents = False
Set rSheet = Worksheets("Report")

tCol = ColumnLetter(target.Column)
'Row number of Target cell that was changed.
tRow = target.Row
'Column number of Target cell that was changed.
iCol = target.Column

With rSheet
Select Case True
Case tCol = "B", tCol = "D"
If .Range(tCol & tRow) = "" Then
.Cells(tRow, iCol + 8).Value = target.Value
Else
.Cells(tRow, iCol + 8).End(xlUp)(2).Value = target.Value
End If
Case tCol = "H"
If .Range(tCol & tRow) = "" Then
.Cells(tRow, iCol + 5).Value = target.Value
Else
.Cells(tRow, iCol + 5).End(xlUp)(2).Value = target.Value
End If
Case tCol = "I", tCol = "J"
Range("I" & tRow & ",J" & tRow).Copy
If .Range("N" & tRow).Value = "" Then
.Range("N" & tRow).PasteSpecial xlPasteValues
Else
.Cells(Rows.Count, "N").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False
Case Else
End Select
End With

Application.EnableEvents = True
End Sub[/VBA]