PDA

View Full Version : Solved: Cut and Paste Value to matching Column



Emoncada
02-24-2012, 11:06 AM
I have a spreadsheet with Column headers from B1:Y1.

in A1 I have an embedded ComboBox with a list of names in the headers.

I want to be able to scan or enter a Value in A2 and Afterupdate, cut that value and move it to it's column based on A1. Then have it stay in A2 for another entry.

Can this be done?

shrivallabha
02-25-2012, 07:25 AM
Right click on Sheet's tab and choose "View Code" then paste this code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range

Application.EnableEvents = False
Application.ScreenUpdating = False

If Target.Address = "$A$2" And Target.Value <> "" Then

Set r = Range("B1:K1").Find(What:=Range("A1").Value, LookIn:=xlValues, Lookat:=xlWhole)
Target.Cut Destination:=Cells(2, r.Column)

End If

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Emoncada
02-26-2012, 08:40 AM
I haven't tested yet, but would this continue to put information down a column like a list if A1 is the same? Or this just places it in row 2 for that column?

shrivallabha
02-26-2012, 09:07 AM
Yes that is correct, the data goes in row 2.

So you want to paste the data into new row every time you make changes in A2. Is this correct?

Then this should work out:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range

Application.EnableEvents = False
Application.ScreenUpdating = False

If Target.Address = "$A$2" And Target.Value <> "" Then

Set r = Range("B1:K1").Find(What:=Range("A1").Value, LookIn:=xlValues, Lookat:=xlWhole)
Target.Cut Destination:=Cells(Cells(Rows.Count, r.Column).End(xlUp)(2).Row, r.Column)

Range("A2").Select

End If

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Emoncada
02-27-2012, 10:45 AM
shrivallabha I appreciate your help. It's working, but after further testing I am getting a Run-time error '13' Type Mismatch when i select 2 cells and delete.

It's taking me to
If Target.Address = "$A$2" And Target.Value <> "" Then

shrivallabha
02-27-2012, 11:04 AM
OK. I had not considered any error handling in the routine. Now this should take care of it.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range

Application.EnableEvents = False
Application.ScreenUpdating = False

On Error GoTo EOSub

If Target.Address = "$A$2" And Target.Value <> "" Then

Set r = Range("B1:K1").Find(What:=Range("A1").Value, LookIn:=xlValues, Lookat:=xlWhole)
Target.Cut Destination:=Cells(Cells(Rows.Count, r.Column).End(xlUp)(2).Row, r.Column)

Range("A2").Select

End If

EOSub:
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Emoncada
02-27-2012, 11:25 AM
Perfect Thank you Shrivallabha!