Writing macros to sequentially change the address of a cell in Exc

[Guest]

I enter data into a spreadsheet on a daily basis and keep a sequential record
of this data.

Rather than copy and paste to build up this historical data base I need a
macro that changes the cell address as new data is entered. This new address
is the next line down in sequence for storing this historical information.

In other words if the last address was C55 after running the macro the next
address would be C56 thence C57 if it is run again. So every time the macro
is run it sequentially directs the data being stored into the next line.

I have used the Find function to get the first line for data storage but
rather than just searching for a key word it remembers the original cell
address and will not allow sequential recording to occur. What I need is to
be able to change the cell address within the macro so future data can be
stored in subsequent cells.

Any assistance would be appreciated

 

[Ken Johnson]

I enter data into a spreadsheet on a daily basis and keep a sequential record
of this data.

Rather than copy and paste to build up this historical data base I need a
macro that changes the cell address as new data is entered. This new address
is the next line down in sequence for storing this historical information.

In other words if the last address was C55 after running the macro the next
address would be C56 thence C57 if it is run again. So every time the macro
is run it sequentially directs the data being stored into the next line.

I have used the Find function to get the first line for data storage but
rather than just searching for a key word it remembers the original cell
address and will not allow sequential recording to occur. What I need is to
be able to change the cell address within the macro so future data can be
stored in subsequent cells.

Any assistance would be appreciated

Hi Ken,

Do you mean something like this...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Cells(Rows.Count, 1).End(xlUp).Row = 1 _
And Range("A2") <> "" Then
MsgBox "You have reached the bottom of the sheet!"
Exit Sub
End If
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(Cells(1, 1), _
Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With Range("A1")
.ClearContents
.Select
End With
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub


It's an event procedure.
It's set up for A1 and could easily be modified to work on any cell.
When new data is entered into A1 it is immediately moved to A2. Also,
all cells (with data) below A1 are moved down as well.

To get the code in place...

1. Copy it
2. Right click the sheet tab then select "View Code" from the popup
menu.
3. Paste the code into the worksheet's code module.
4. Press Alt + F11 to get back to Excel's user interface.

The code will only work if your Security setting is "Medium". If this
is not the case then...

1. Go Tools|Macro|Security...then click on Medium then click OK
2. Close the workbook then reopen it.
3. Click "Enable Macros" on the "Security Warning" dialog. Everytime
the workbook is opened you must click "Enable Macros".

Ken Johnson

 

[Ken Johnson]

Hi Ken,

This version only requires one simple change to change the cell used as
the input cell.
For example, if C55 is your input cell then you only have to change the
first line to...

Dim rngInput As Range: Set rngInput = Range("C55")

Private Sub Worksheet_Change(ByVal Target As Range)
'Change the address string below to suit your needs
Dim rngInput As Range: Set rngInput = Range("B3") '<<<
If Not Intersect(Target, rngInput) Is Nothing Then
If Cells(Rows.Count, rngInput.Column).End(xlUp).Row = _
rngInput.Row And rngInput.Offset(1, 0).Value <> "" Then
MsgBox "You have reached the bottom of the sheet!"
Exit Sub
End If
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(rngInput, Cells(Cells(Rows.Count, _
rngInput.Column).End(xlUp).Row, rngInput.Column))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With rngInput
.ClearContents
.Select
End With
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub


Ken Johnson

 

[Rod Gill]

I always name the cell of the first title. So if my title is A4, I name A4.
I expect the first row of data to start at A5. This way, if anyone inserts
or delete a title row, my code continues to work. Then:

Sub NewData()
Dim Rng As Range
Dim NextCell As Range
Set Rng = Range("First Title")
If IsEmpty(Rng.Offset(1, 0)) Then
Set NextCell = Rng.Offset(1, 0)
Else
NextCell = Rng.End(xlDown).Offset(1, 0)
End If
End Sub

Works well. This code also assumes that the first column of data always has
a value, otherwise the end method doesn't work. Note that End(xlDown) is the
same as Ctrl+Down.

 

[Guest]

--
Ken living downunder

Hi Ken,

Do you mean something like this...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Cells(Rows.Count, 1).End(xlUp).Row = 1 _
And Range("A2") <> "" Then
MsgBox "You have reached the bottom of the sheet!"
Exit Sub
End If
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(Cells(1, 1), _
Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With Range("A1")
.ClearContents
.Select
End With
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub


It's an event procedure.
It's set up for A1 and could easily be modified to work on any cell.
When new data is entered into A1 it is immediately moved to A2. Also,
all cells (with data) below A1 are moved down as well.

To get the code in place...

1. Copy it
2. Right click the sheet tab then select "View Code" from the popup
menu.
3. Paste the code into the worksheet's code module.
4. Press Alt + F11 to get back to Excel's user interface.

The code will only work if your Security setting is "Medium". If this
is not the case then...

1. Go Tools|Macro|Security...then click on Medium then click OK
2. Close the workbook then reopen it.
3. Click "Enable Macros" on the "Security Warning" dialog. Everytime
the workbook is opened you must click "Enable Macros".

Ken Johnson

 

[Guest]

--
Ken living downunder

Hi Ken,

Do you mean something like this...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Cells(Rows.Count, 1).End(xlUp).Row = 1 _
And Range("A2") <> "" Then
MsgBox "You have reached the bottom of the sheet!"
Exit Sub
End If
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(Cells(1, 1), _
Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With Range("A1")
.ClearContents
.Select
End With
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub


It's an event procedure.
It's set up for A1 and could easily be modified to work on any cell.
When new data is entered into A1 it is immediately moved to A2. Also,
all cells (with data) below A1 are moved down as well.

To get the code in place...

1. Copy it
2. Right click the sheet tab then select "View Code" from the popup
menu.
3. Paste the code into the worksheet's code module.
4. Press Alt + F11 to get back to Excel's user interface.

The code will only work if your Security setting is "Medium". If this
is not the case then...

1. Go Tools|Macro|Security...then click on Medium then click OK
2. Close the workbook then reopen it.
3. Click "Enable Macros" on the "Security Warning" dialog. Everytime
the workbook is opened you must click "Enable Macros".

Ken Johnson

Hi Ken

Thanks for your help. I will be leaving today (Christmas eve down here) with
my wife to spend Christmas with our son and grand children who live in
Brisbane.

Will try on my return. Have an enjoyable Christmas and New Year

Many thanks

Ken Pearson

 

[Guest]

--
Ken living downunder

Hi Ken,

This version only requires one simple change to change the cell used as
the input cell.
For example, if C55 is your input cell then you only have to change the
first line to...

Dim rngInput As Range: Set rngInput = Range("C55")

Private Sub Worksheet_Change(ByVal Target As Range)
'Change the address string below to suit your needs
Dim rngInput As Range: Set rngInput = Range("B3") '<<<
If Not Intersect(Target, rngInput) Is Nothing Then
If Cells(Rows.Count, rngInput.Column).End(xlUp).Row = _
rngInput.Row And rngInput.Offset(1, 0).Value <> "" Then
MsgBox "You have reached the bottom of the sheet!"
Exit Sub
End If
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(rngInput, Cells(Cells(Rows.Count, _
rngInput.Column).End(xlUp).Row, rngInput.Column))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With rngInput
.ClearContents
.Select
End With
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub


Ken Johnson

Hi Ken again

Thanks for your follow up

Best regards

Ken Pearson

 

[Guest]

--
Ken living downunder

I always name the cell of the first title. So if my title is A4, I name A4.
I expect the first row of data to start at A5. This way, if anyone inserts
or delete a title row, my code continues to work. Then:

Sub NewData()
Dim Rng As Range
Dim NextCell As Range
Set Rng = Range("First Title")
If IsEmpty(Rng.Offset(1, 0)) Then
Set NextCell = Rng.Offset(1, 0)
Else
NextCell = Rng.End(xlDown).Offset(1, 0)
End If
End Sub

Works well. This code also assumes that the first column of data always has
a value, otherwise the end method doesn't work. Note that End(xlDown) is the
same as Ctrl+Down.

--

Rod Gill



Hi Rod

Thanks for your interest and help.

As I have stated in my pervious responses my wife andI will be flying to
Brisbane to spend Christmas with our son and his family.

I will try yours and the other help I have received on my return.

Have a Merry Christmas and a pleasant New Year. Christmas here as usual
will be warm to hot, no snow down here.

Best regards

Ken Pearson

 

[Ken Johnson]

--
Ken living downunder




Thanks for your help. I will be leaving today (Christmas eve down here) with
my wife to spend Christmas with our son and grand children who live in
Brisbane.

Will try on my return. Have an enjoyable Christmas and New Year

Many thanks

Ken Pearson

Hi Ken,

I hope Brisbane wasn't too hot and muggy.

Version 3 enables you to have more than one input cell on the sheet.
Just edit the address string in the line...

Dim rngInput As Range: Set rngInput = Range("B3,D3,F3")

As it stands, B3, D3 and F3 are input cells. If you wanted the first
four cells in the second row to be input cells you would change the
address string to "A22".

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ERRORHANDLER
'Change the address string below to suit your needs
Dim rngInput As Range: Set rngInput = Range("B3,D3,F3") '<<<
If Not Intersect(Target, rngInput) Is Nothing Then
Application.ScreenUpdating = False
Dim rngCell As Range
For Each rngCell In Intersect(Target, rngInput)
If Cells(Rows.Count, rngCell.Column).End(xlUp).Row = _
rngCell.Row And rngCell.Offset(1, 0).Value <> "" Then
MsgBox "You have reached the bottom of the sheet" _
& vbNewLine & "in column " _
& Mid(rngCell.Address, 2, _
WorksheetFunction.Find("$", rngCell.Address, 2) - 2)
GoTo NEXT_rngCell
End If
Application.EnableEvents = False
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(rngCell, Cells(Cells(Rows.Count, _
rngCell.Column).End(xlUp).Row, rngCell.Column))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With rngCell
.ClearContents
.Select
End With
NEXT_rngCell: Next rngCell
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
Me.Protect
End Sub

Ken Johnson

 

[Ken Johnson]

Hi Ken,

I hope Brisbane wasn't too hot and muggy.

Version 3 enables you to have more than one input cell on the sheet.
Just edit the address string in the line...

Dim rngInput As Range: Set rngInput = Range("B3,D3,F3")

As it stands, B3, D3 and F3 are input cells. If you wanted the first
four cells in the second row to be input cells you would change the
address string to "A22".

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ERRORHANDLER
'Change the address string below to suit your needs
Dim rngInput As Range: Set rngInput = Range("B3,D3,F3") '<<<
If Not Intersect(Target, rngInput) Is Nothing Then
Application.ScreenUpdating = False
Dim rngCell As Range
For Each rngCell In Intersect(Target, rngInput)
If Cells(Rows.Count, rngCell.Column).End(xlUp).Row = _
rngCell.Row And rngCell.Offset(1, 0).Value <> "" Then
MsgBox "You have reached the bottom of the sheet" _
& vbNewLine & "in column " _
& Mid(rngCell.Address, 2, _
WorksheetFunction.Find("$", rngCell.Address, 2) - 2)
GoTo NEXT_rngCell
End If
Application.EnableEvents = False
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(rngCell, Cells(Cells(Rows.Count, _
rngCell.Column).End(xlUp).Row, rngCell.Column))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With rngCell
.ClearContents
.Select
End With
NEXT_rngCell: Next rngCell
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
Me.Protect
End Sub

Ken Johnson

Hi Ken,

Oops! I was fooling around with Sheet Protection at some stage then I
neglected to remove all of that part of the code before posting Version
3, so use this instead, or just delete the second last line
(Me.Protect)...

Private Sub Worksheet_Change(ByVal Target As Range)
'Change the address string below to suit your needs
On Error GoTo ERRORHANDLER
Dim rngInput As Range: Set rngInput = Range("A11") '<<<
If Not Intersect(Target, rngInput) Is Nothing Then
Application.ScreenUpdating = False
Dim rngCell As Range
For Each rngCell In Intersect(Target, rngInput)
If Cells(Rows.Count, rngCell.Column).End(xlUp).Row = _
rngCell.Row And rngCell.Offset(1, 0).Value <> "" Then
MsgBox "You have reached the bottom of the sheet" _
& vbNewLine & "in column " _
& Mid(rngCell.Address, 2, _
WorksheetFunction.Find("$", rngCell.Address, 2) - 2)
GoTo NEXT_rngCell
End If
Application.EnableEvents = False
Dim rngOld As Range, rngNew As Range
Set rngOld = Range(rngCell, Cells(Cells(Rows.Count, _
rngCell.Column).End(xlUp).Row, rngCell.Column))
Set rngNew = rngOld.Offset(1, 0)
rngNew.Value = rngOld.Value
With rngCell
.ClearContents
.Select
End With
NEXT_rngCell: Next rngCell
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub

Ken Johnson

 

[Ken Johnson]

Hi Ken,

I've been looking at how others achieve the same effect and have
discovered it's a lot easier than I thought. It turns out that all that
is needed to shift all of the old data cells down one row is .Insert
Shift:= xlDown.

Also, the way that I was checking that there was still space on the
sheet for moving the data down one more row was logically flawed, so
I've fixed that up too. The logically correct way also turned out to be
a lot simpler than I originally thought.

So, hopefully my final version is...

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim rngInput As Range
Dim rngCell As Range
Set rngInput = Range("A2") '<<<<<<<<<<<<<<<<<<<<<<
'Edit rngInput's Address String to suit your needs^
'Examples...
' "A2,C2" for A2 and C2
' "D1:G1" for D1, E1, F1 and G1
' "A2,C2,D1:G1" for A2, C2, D1, E1, F1 and G1.
If Not Intersect(Target, rngInput) Is Nothing Then
On Error GoTo ERRORHANDLER
Application.EnableEvents = False
For Each rngCell In Intersect(Target, rngInput)
If rngCell.Value <> "" Then
If Cells(Rows.Count, _
rngCell.Column).Value = "" Then
rngCell.Insert shift:=xlDown
With rngCell.Offset(-1, 0)
.ClearContents
.Select
End With
Else: MsgBox "No more room in column " _
& Mid(rngCell.Address, 2, _
WorksheetFunction.Find( _
"$", rngCell.Address, 2) - 2)
End If
End If
Next rngCell
Application.EnableEvents = True
End If
Exit Sub
ERRORHANDLER: Application.EnableEvents = True
End Sub


Ken Johnson

 

[Guest]

--
Ken living downunder

--
Ken living downunder



Thanks for your interest and help.

As I have stated in my pervious responses my wife andI will be flying to
Brisbane to spend Christmas with our son and his family.

I will try yours and the other help I have received on my return.

Have a Merry Christmas and a pleasant New Year. Christmas here as usual
will be warm to hot, no snow down here.

Best regards

Ken Pearson

By Ken Pearson


I have found the responses helpful even though they did not give the
solution I needed.

The solution I developed is given by the macro below.

Part 1 of macro converts dates from month/day format into day/month. This is
the format used in OZ.

Part 2 is below this provides the macro that sequentially logs data into new
rows

' PART 2 of Macro

' Sequentially logs daily data

' Finds new row to record current lot of data

Cells.Find(What:="xray", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False, SearchFormat:=False).Activate




' Prepares cell to identify next row that will record next lot of new data

Dim Rnge As Range

Set Rnge = ActiveCell

Rnge.Offset(1, 0).Activate

ActiveCell.FormulaR1C1 = "xray"

' Copies cells C19:G19 (Date:Volume) into selected new row


Range("b19:g19").Select
Selection.Copy

Rnge.Offset(0, 0).Activate
ActiveCell.Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False


Range("b19").Select



'
End Sub

This is a simple macro that can be used to sequentially log data.

Best regards

Ken Pearson