Copy Value of Active cell and 25 rows above to a diff worksheet

[ash3154]

Hello,

I am hoping someone can assist me. My spreadsheets consists of 70 columns
and 2000 rows.
If my active cell is bx400, I would like to copy value of bx399 into
spreadsheet "X"'s cell a9. Then take the value of bx398 and copy that into
spreadsheet "X" 's cell ac11, bx397 would be copied to sheet X cell c19 and
so on for the previous 25 rows. (This should only be done when I click on
the macro button)

 

[JLatham]

Here's a macro that should do what you've asked for. You have some work to
do to complete the code: you need to change
Const destSheetName = "X" ' change as needed
to the actual name of the destination sheet instead of "X", so if your
destination sheet's name is Sheet3 it would change to = "Sheet3"

Then farther down in the code you have to provide the destination cell
addresses for the elements of array cellMap(). I put in the 1st 3 based on
your posting, but you need to provide the ones for cellMap(4) through
cellMap(25).

To put the code into the workbook, open it and press [Alt]+[F11] to open the
VB Editor. In it, choose Insert --> Module and then copy the code below and
paste it into the module and edit it as required. Then close the VB Editor.
To run it later, choose the cell in column BX below the first cell you want
to copy and use Tools --> Macro --> Macros and choose it from the list and
click [Run]. Or you can put a button or shape on the source sheet and assign
the macro to it.

Sub CopyFromColumnBX()
'this should be the name of your 'X' sheet
'the sheet to copy from BX into
Const destSheetName = "X" ' change as needed
Dim destSheet As Worksheet
'this array will hold the addresses of the
'cells on sheet 'X' that the data is to
'be copied into.
Dim cellMap(1 To 25) As String
Dim LC As Integer ' loop counter

If ActiveCell.Column <> Range("BX1").Column Then
Exit Sub ' not in column BX
End If
'if we get here, we have work to do
'fill the array with the destination
'addresses.
cellMap(1) = "A9"
cellMap(2) = "AC11"
cellMap(3) = "C19"
'you need to fill in the rest of the
'destination cell addresses
cellMap(4) = ""
cellMap(5) = ""
cellMap(6) = ""
cellMap(7) = ""
cellMap(8) = ""
cellMap(9) = ""
cellMap(10) = ""
cellMap(11) = ""
cellMap(12) = ""
cellMap(13) = ""
cellMap(14) = ""
cellMap(15) = ""
cellMap(16) = ""
cellMap(17) = ""
cellMap(18) = ""
cellMap(19) = ""
cellMap(20) = ""
cellMap(21) = ""
cellMap(22) = ""
cellMap(23) = ""
cellMap(24) = ""
cellMap(25) = ""
'this is where the work actually gets done
Set destSheet = _
ThisWorkbook.Worksheets(destSheetName)
For LC = LBound(cellMap) To UBound(cellMap)
'safety valve if no address in cellMap() entry
If cellMap(LC) <> "" Then
destSheet.Range(cellMap(LC)) = _
ActiveCell.Offset(LC * -1, 0)
End If
Next
Set destSheet = Nothing ' housekeeping
End Sub

 

[ash3154]

Thanks for a quick response,
based on this this will only work with column bx, since I have 70 cols, will
I have to create a macro for each columns?

Messing around, this is what I have come up so far, i just did a test run in
1 column, and seem to work.

Option Explicit

Sub InsertRows_n_CopyCell()


Dim mycell As Range
Set mycell = ActiveCell.Offset(0, 0)
Dim myrange As Range
Set myrange = Range(ActiveCell.Offset(0, 0), mycell)

'Start a Looping procedure
Do While ActiveCell.Value = "g"

'Move up 10 rows
ActiveCell.Offset(-10).Select
Selection.Copy
Range("E18").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False


mycell.Select
ActiveCell.Offset(-9).Select
Selection.Copy
Range("E19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

mycell.Select
ActiveCell.Offset(-8).Select
Selection.Copy
Range("E20").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False
Range("E19").Select

Loop
End Sub

Here's a macro that should do what you've asked for. You have some work to
do to complete the code: you need to change
Const destSheetName = "X" ' change as needed
to the actual name of the destination sheet instead of "X", so if your
destination sheet's name is Sheet3 it would change to = "Sheet3"

Then farther down in the code you have to provide the destination cell
addresses for the elements of array cellMap(). I put in the 1st 3 based on
your posting, but you need to provide the ones for cellMap(4) through
cellMap(25).

To put the code into the workbook, open it and press [Alt]+[F11] to open the
VB Editor. In it, choose Insert --> Module and then copy the code below and
paste it into the module and edit it as required. Then close the VB Editor.
To run it later, choose the cell in column BX below the first cell you want
to copy and use Tools --> Macro --> Macros and choose it from the list and
click [Run]. Or you can put a button or shape on the source sheet and assign
the macro to it.

Sub CopyFromColumnBX()
'this should be the name of your 'X' sheet
'the sheet to copy from BX into
Const destSheetName = "X" ' change as needed
Dim destSheet As Worksheet
'this array will hold the addresses of the
'cells on sheet 'X' that the data is to
'be copied into.
Dim cellMap(1 To 25) As String
Dim LC As Integer ' loop counter

If ActiveCell.Column <> Range("BX1").Column Then
Exit Sub ' not in column BX
End If
'if we get here, we have work to do
'fill the array with the destination
'addresses.
cellMap(1) = "A9"
cellMap(2) = "AC11"
cellMap(3) = "C19"
'you need to fill in the rest of the
'destination cell addresses
cellMap(4) = ""
cellMap(5) = ""
cellMap(6) = ""
cellMap(7) = ""
cellMap(8) = ""
cellMap(9) = ""
cellMap(10) = ""
cellMap(11) = ""
cellMap(12) = ""
cellMap(13) = ""
cellMap(14) = ""
cellMap(15) = ""
cellMap(16) = ""
cellMap(17) = ""
cellMap(18) = ""
cellMap(19) = ""
cellMap(20) = ""
cellMap(21) = ""
cellMap(22) = ""
cellMap(23) = ""
cellMap(24) = ""
cellMap(25) = ""
'this is where the work actually gets done
Set destSheet = _
ThisWorkbook.Worksheets(destSheetName)
For LC = LBound(cellMap) To UBound(cellMap)
'safety valve if no address in cellMap() entry
If cellMap(LC) <> "" Then
destSheet.Range(cellMap(LC)) = _
ActiveCell.Offset(LC * -1, 0)
End If
Next
Set destSheet = Nothing ' housekeeping
End Sub

Hello,

I am hoping someone can assist me. My spreadsheets consists of 70 columns
and 2000 rows.
If my active cell is bx400, I would like to copy value of bx399 into
spreadsheet "X"'s cell a9. Then take the value of bx398 and copy that into
spreadsheet "X" 's cell ac11, bx397 would be copied to sheet X cell c19 and
so on for the previous 25 rows. (This should only be done when I click on
the macro button)

 

[JLatham]

Sorry about that 'bx' thing - but I was going by your problem description
which didn't mention other columns possibly needing to be used.

It's still difficult to determine if you can get away with 1 macro or will
need 70. It depends mostly on the "mapping" of the source cells to the
destination cells and whether the destination sheet is always the same or not.

If the destination sheet is always the same, and the destination cells are
always the same, then one routine could fit all: we'd just ignore the test to
see if we are in column BX or not. You'd only need to delete the

If ActiveCell.Column <> Range("BX1").Column Then
Exit Sub
End If

statements from the code to allow it to work from any column (but it would
assume that the destination cells are the same regardless of which column you
currently have selected (and that they are on the same destination sheet).


But if the destination cells vary based on what column you have chosen to
copy from, then you're probably going to need to add a SELECT CASE block to
determine which column you are in and then set up the cell map based on that
result. A kind of 70-in-1 solution.

Thanks for a quick response,
based on this this will only work with column bx, since I have 70 cols, will
I have to create a macro for each columns?

Messing around, this is what I have come up so far, i just did a test run in
1 column, and seem to work.

Option Explicit

Sub InsertRows_n_CopyCell()


Dim mycell As Range
Set mycell = ActiveCell.Offset(0, 0)
Dim myrange As Range
Set myrange = Range(ActiveCell.Offset(0, 0), mycell)

'Start a Looping procedure
Do While ActiveCell.Value = "g"

'Move up 10 rows
ActiveCell.Offset(-10).Select
Selection.Copy
Range("E18").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False


mycell.Select
ActiveCell.Offset(-9).Select
Selection.Copy
Range("E19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

mycell.Select
ActiveCell.Offset(-8).Select
Selection.Copy
Range("E20").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False
Range("E19").Select

Loop
End Sub

Here's a macro that should do what you've asked for. You have some work to
do to complete the code: you need to change
Const destSheetName = "X" ' change as needed
to the actual name of the destination sheet instead of "X", so if your
destination sheet's name is Sheet3 it would change to = "Sheet3"

Then farther down in the code you have to provide the destination cell
addresses for the elements of array cellMap(). I put in the 1st 3 based on
your posting, but you need to provide the ones for cellMap(4) through
cellMap(25).

To put the code into the workbook, open it and press [Alt]+[F11] to open the
VB Editor. In it, choose Insert --> Module and then copy the code below and
paste it into the module and edit it as required. Then close the VB Editor.
To run it later, choose the cell in column BX below the first cell you want
to copy and use Tools --> Macro --> Macros and choose it from the list and
click [Run]. Or you can put a button or shape on the source sheet and assign
the macro to it.

Sub CopyFromColumnBX()
'this should be the name of your 'X' sheet
'the sheet to copy from BX into
Const destSheetName = "X" ' change as needed
Dim destSheet As Worksheet
'this array will hold the addresses of the
'cells on sheet 'X' that the data is to
'be copied into.
Dim cellMap(1 To 25) As String
Dim LC As Integer ' loop counter

If ActiveCell.Column <> Range("BX1").Column Then
Exit Sub ' not in column BX
End If
'if we get here, we have work to do
'fill the array with the destination
'addresses.
cellMap(1) = "A9"
cellMap(2) = "AC11"
cellMap(3) = "C19"
'you need to fill in the rest of the
'destination cell addresses
cellMap(4) = ""
cellMap(5) = ""
cellMap(6) = ""
cellMap(7) = ""
cellMap(8) = ""
cellMap(9) = ""
cellMap(10) = ""
cellMap(11) = ""
cellMap(12) = ""
cellMap(13) = ""
cellMap(14) = ""
cellMap(15) = ""
cellMap(16) = ""
cellMap(17) = ""
cellMap(18) = ""
cellMap(19) = ""
cellMap(20) = ""
cellMap(21) = ""
cellMap(22) = ""
cellMap(23) = ""
cellMap(24) = ""
cellMap(25) = ""
'this is where the work actually gets done
Set destSheet = _
ThisWorkbook.Worksheets(destSheetName)
For LC = LBound(cellMap) To UBound(cellMap)
'safety valve if no address in cellMap() entry
If cellMap(LC) <> "" Then
destSheet.Range(cellMap(LC)) = _
ActiveCell.Offset(LC * -1, 0)
End If
Next
Set destSheet = Nothing ' housekeeping
End Sub

Hello,

I am hoping someone can assist me. My spreadsheets consists of 70 columns
and 2000 rows.
If my active cell is bx400, I would like to copy value of bx399 into
spreadsheet "X"'s cell a9. Then take the value of bx398 and copy that into
spreadsheet "X" 's cell ac11, bx397 would be copied to sheet X cell c19 and
so on for the previous 25 rows. (This should only be done when I click on
the macro button)

 

[ash3154]

I am sorry, I got pulled into something, I will work on this as soon as I get
back on this project.

Thanks,
Ash

Sorry about that 'bx' thing - but I was going by your problem description
which didn't mention other columns possibly needing to be used.

It's still difficult to determine if you can get away with 1 macro or will
need 70. It depends mostly on the "mapping" of the source cells to the
destination cells and whether the destination sheet is always the same or not.

If the destination sheet is always the same, and the destination cells are
always the same, then one routine could fit all: we'd just ignore the test to
see if we are in column BX or not. You'd only need to delete the

If ActiveCell.Column <> Range("BX1").Column Then
Exit Sub
End If

statements from the code to allow it to work from any column (but it would
assume that the destination cells are the same regardless of which column you
currently have selected (and that they are on the same destination sheet).


But if the destination cells vary based on what column you have chosen to
copy from, then you're probably going to need to add a SELECT CASE block to
determine which column you are in and then set up the cell map based on that
result. A kind of 70-in-1 solution.

Thanks for a quick response,
based on this this will only work with column bx, since I have 70 cols, will
I have to create a macro for each columns?

Messing around, this is what I have come up so far, i just did a test run in
1 column, and seem to work.

Option Explicit

Sub InsertRows_n_CopyCell()


Dim mycell As Range
Set mycell = ActiveCell.Offset(0, 0)
Dim myrange As Range
Set myrange = Range(ActiveCell.Offset(0, 0), mycell)

'Start a Looping procedure
Do While ActiveCell.Value = "g"

'Move up 10 rows
ActiveCell.Offset(-10).Select
Selection.Copy
Range("E18").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False


mycell.Select
ActiveCell.Offset(-9).Select
Selection.Copy
Range("E19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

mycell.Select
ActiveCell.Offset(-8).Select
Selection.Copy
Range("E20").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False
Range("E19").Select

Loop
End Sub

Here's a macro that should do what you've asked for. You have some work to
do to complete the code: you need to change
Const destSheetName = "X" ' change as needed
to the actual name of the destination sheet instead of "X", so if your
destination sheet's name is Sheet3 it would change to = "Sheet3"

Then farther down in the code you have to provide the destination cell
addresses for the elements of array cellMap(). I put in the 1st 3 based on
your posting, but you need to provide the ones for cellMap(4) through
cellMap(25).

To put the code into the workbook, open it and press [Alt]+[F11] to open the
VB Editor. In it, choose Insert --> Module and then copy the code below and
paste it into the module and edit it as required. Then close the VB Editor.
To run it later, choose the cell in column BX below the first cell you want
to copy and use Tools --> Macro --> Macros and choose it from the list and
click [Run]. Or you can put a button or shape on the source sheet and assign
the macro to it.

Sub CopyFromColumnBX()
'this should be the name of your 'X' sheet
'the sheet to copy from BX into
Const destSheetName = "X" ' change as needed
Dim destSheet As Worksheet
'this array will hold the addresses of the
'cells on sheet 'X' that the data is to
'be copied into.
Dim cellMap(1 To 25) As String
Dim LC As Integer ' loop counter

If ActiveCell.Column <> Range("BX1").Column Then
Exit Sub ' not in column BX
End If
'if we get here, we have work to do
'fill the array with the destination
'addresses.
cellMap(1) = "A9"
cellMap(2) = "AC11"
cellMap(3) = "C19"
'you need to fill in the rest of the
'destination cell addresses
cellMap(4) = ""
cellMap(5) = ""
cellMap(6) = ""
cellMap(7) = ""
cellMap(8) = ""
cellMap(9) = ""
cellMap(10) = ""
cellMap(11) = ""
cellMap(12) = ""
cellMap(13) = ""
cellMap(14) = ""
cellMap(15) = ""
cellMap(16) = ""
cellMap(17) = ""
cellMap(18) = ""
cellMap(19) = ""
cellMap(20) = ""
cellMap(21) = ""
cellMap(22) = ""
cellMap(23) = ""
cellMap(24) = ""
cellMap(25) = ""
'this is where the work actually gets done
Set destSheet = _
ThisWorkbook.Worksheets(destSheetName)
For LC = LBound(cellMap) To UBound(cellMap)
'safety valve if no address in cellMap() entry
If cellMap(LC) <> "" Then
destSheet.Range(cellMap(LC)) = _
ActiveCell.Offset(LC * -1, 0)
End If
Next
Set destSheet = Nothing ' housekeeping
End Sub

:

Hello,

I am hoping someone can assist me. My spreadsheets consists of 70 columns
and 2000 rows.
If my active cell is bx400, I would like to copy value of bx399 into
spreadsheet "X"'s cell a9. Then take the value of bx398 and copy that into
spreadsheet "X" 's cell ac11, bx397 would be copied to sheet X cell c19 and
so on for the previous 25 rows. (This should only be done when I click on
the macro button)