Help with vba to activate on input of cell

[A Thayuman]

Hi I hope that I can be helped with using activate on input cell

'Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Traget, Range("A2:D2")) Is Nothing Then

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select

ActiveSheet.Paste

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge

End If

End Sub

The current macro as see below works fine without adding this feature however when I use the above and when it is in module 1
Sub test()
'Copy Invoice Number to Data Sheet

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select

ActiveSheet.Paste

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End Sub

Mr.xlsm
	A	B	C	D	E	F	G	H
1	Customer ID				Customer Name
2	126				Jack Garret
Sheet1

Mr.xlsm
	A	B
1	Customer ID	Customer Name
2	123	Jack Garret
3	123
4	123
Sheet2

 

[Skyybot]

What exactly are you trying to do? Unmerge cells but keep the data?

 

[A Thayuman]

What exactly are you trying to do? Unmerge cells but keep the data?

Thanks for responding to my call for help.

I would like to copy from merged cells from Sheet1 to a single cell in Sheet2, using the VBA to activate when I change data in Cell "A2" in Sheet1.

the code below works fine when in a module (However I have to use a short cut key or Run Sub)

Sub test()
'Copy Invoice Number to Data Sheet

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select

ActiveSheet.Paste

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End Sub

However when I try to change it to so that I dont have to hit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Traget, Range("A2:D2")) Is Nothing Then
with the same code
End If

End Sub

If does not work and gets stuck at "Range("A1").Activate", I tried ".Select" same result

Regards Anil

What exactly are you trying to do? Unmerge cells but keep the data?

I would like to copy data from Sheet1 where rows are merged (Say "A2:D2") ,to sheet2 in a single cell Say ("A2")
Also in sheet2, if cell "A2" has information then cell "A3" is filled.
I hope to use to activate the VBA when information in Sheet1 ("A2") is changed

 

[Skyybot]

Try this and see if you get the results that you desire. Please make sure that this Macro is placed in Sheet1 of the VBA project.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target = Worksheets("Sheet1").Range("A2") Then
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End If
End Sub

 

[A Thayuman]

Try this and see if you get the results that you desire. Please make sure that this Macro is placed in Sheet1 of the VBA project.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target = Worksheets("Sheet1").Range("A2") Then
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End If
End Sub

Thanks Skybolt for the code however please see image -its stops at the first line of code

 

[A Thayuman]

I dont understand the code as seen below works in the module and not we try to activate it with the "IF Then and End If"?

Sub test()
'Copy Invoice Number to Data Sheet

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select

ActiveSheet.Paste

Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End Sub

Thanks again Skybolt

 

[Skyybot]

My fault. Try this small change the code in Sheet1 in the VBA project.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$2" Then
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End If
End Sub

 

[A Thayuman]

Hi Skybolt,

I tried adding the new code in Sheet1 - now there code does not do anything, There is no Debug error in the VBA Code either

Thanks for the effort I wonder I you would like to advice me again Regards Anil

 

[Skyybot]

I added two Message Boxes to see if the code is running but just not doing what we want. Let me know which Message Box you see.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$2" Then
MsgBox "Found Target",vbInformation,"Sub Test"
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End If
MsgBox "Didn't find Target but code did run.",vbInformation,"Sub Test"
End Sub

 

[A Thayuman]

I added two Message Boxes to see if the code is running but just not doing what we want. Let me know which Message Box you see.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$A$2" Then
MsgBox "Found Target",vbInformation,"Sub Test"
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.UnMerge
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Activate
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A2:D2").Select
Selection.Merge
End If
MsgBox "Didn't find Target but code did run.",vbInformation,"Sub Test"
End Sub

Thanks again Skybolt please see image attached, Thanks you once again for the effort put in