VBA - Move Certain cells (column) based off of contents of row.

[Oranjin]

I have seating arrangement in excel that I'm trying to spiff up. I have begun to embark on the great mystery of actually making macro's work. So far, I'm a little over my head. I would appreciate any help with this, I cannot imagine it's very complicated for someone who knows what they are doing.

I want to be able to say, "I want to move Steve Steve to Cubicle 4030" From wherever he is now. These are some additonal parameters

1. If someone is seated in 4017 then I don't want bob to be moved there. I want a warning that says, "Someone is currently seated there"
2. The following columns have formulas that I don't want to be taken with bob when he moves, because they'll auto-populate in bob's new row.
   1. D,E,F and L

Below is an example of the data to be arranged:

A

B

C

D

E

F

G

H

I

J

K

L

M

550

Departments

Teams

660 Floor

660 Quad

Samaccountname

Seat Type

First Name

Last Name

Display Name

Station Location

Workstation Power Port

551

Finance

A

2

SE

Steve.Steve

Support

Steve

Steve

Steve Steve

2212

East 76

552

Implementation

B

3

SW

Dave.Dave

Support

Dave

Dave

Dave Dave

3130

West 76

553

Open

4

NW

Open Slot

Open Slot

4030

West 85

<tbody>
</tbody>

To reiterate:

I want to be able to enter "Move Steve to cubicle 4030" and then have columns B,C,G.H,I from row 550 to 553 w/out overwriting the forumals that are in D, E, F and L. Additionally, if I were to enter, "Move Steve to cubicle 3130" I would want to have the cell turn red where you enter the necessary information, and or get some sort of warning that said, "There is someone currently in that cubicle"

Any help is appreciated.

Thanks

 

[Snakehips]

Oranjin,

I'm assuming that columns BC GHI have data moved and DEF JKL contain formula ??

Name to move in F2 and seat to move to in H2 '*** edit the code to change to actual input cells
My data starts with headers in row 5.
If yours is e.g. 550 as appears above then edit to suit in the code line that sets fr

Excel Workbook
	B	C	D	E	F	G	H	I	J	K	L
1	*	*	*	*	Display Name	*	Seat	*	*	*	*
2	*	*	*	Move	Steve Steve	To	4030	*	*	*	*
3	*	*	*	*	*	*	*	*	*	*	*
4	*	*	*	*	*	*	*	*	*	*	*
5	Departments	Teams	660 Floor	660 Quad	Samaccountname	Seat Type	First Name	Last Name	Display Name	Station Location	Workstation Power Port
6	*	*	2	SE	*	*	*	*	*	2212	East 76
7	Implementation	B	3	SW	Dave.Dave	Support	Dave	Dave	Dave Dave	3130	West 76
8	Finance	A	4	NW	Steve.Steve	Support	Steve	Steve	Steve Steve	4030	West 85
Sheet2

This code hopefully does what you want or will give you a good start.

Sub Move_Seat()


Person = Range("F2")
Seat = Range("H2")


fr = 5  '******edit for your first row  i.e.  data headers row  550 ?


lr = Cells(Rows.Count, "K").End(xlUp).Row 'last row by testing column K




'Find person row using column J
On Error Resume Next
pr = WorksheetFunction.Match(Person, Range("J" & fr & ":J" & lr), 0) + fr - 1


'Bail out if not found
If Not pr > 0 Then
    MsgBox "Cannot match that name.  Please try again"
    On Error GoTo 0
    Exit Sub
End If


'Find new seat row using column K
sr = WorksheetFunction.Match(Seat, Range("K" & fr & ":K" & lr), 0) + fr - 1


'Bail out if not found


If Not sr > 0 Then
    MsgBox "Cannot match that saet.  Please try again"
    On Error GoTo 0
    Exit Sub
End If
    
'Otherwise, test if new seat is occupied by cheking H & I for names ??
If Range("H" & sr) = "" And Range("I" & sr) = "" Then   'seat is not occupied so..
   'surpress screen updates and calculation
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
    'move details
     Range("B" & sr & ":C" & sr).Value = Range("B" & pr & ":C" & pr).Value
     Range("G" & sr & ":I" & sr).Value = Range("G" & pr & ":I" & pr).Value
     
     'Clear old details
     Range("B" & pr & ":C" & pr).ClearContents
     Range("G" & pr & ":I" & pr).ClearContents
    'reset update and calc
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    Else    'otherwise..
    
    MsgBox "That seat is occupied.  Please try again."
    On Error GoTo 0
End If


End Sub

Hope that helps.

 

[Oranjin]

I changed a couple of things to get it working. It's running at a clip. I added one more subscript. You'll see. What I don't understand is, the subscript is dropping those values into the range I have selected. I would like the values Open, Open Slot and Open Slot to fall into the following cells.

b= "Open"
C= " "
D= Formula - Leave as is
E = Formula - Leave as is
F = Formula - Leave as is
G = "Open Slot"
H= " "
I = " "
J= Formula - Leave as is

I think that code I added is pretty close. Please let me know what additions I need to make.

Steve

Sub Move_Seat()




Person = Range("F2")
Seat = Range("H2")




fr = 12  '******edit for your first row  i.e.  data headers row  550 ?




lr = Cells(Rows.Count, "K").End(xlUp).Row 'last row by testing column K








'Find person row using column J
On Error Resume Next
pr = WorksheetFunction.Match(Person, Range("J" & fr & ":J" & lr), 0) + fr - 1




'Bail out if not found
If Not pr > 0 Then
    MsgBox "Cannot match that name.  Please try again"
    On Error GoTo 0
    Exit Sub
End If




'Find new seat row using column K
sr = WorksheetFunction.Match(Seat, Range("K" & fr & ":K" & lr), 0) + fr - 1




'Bail out if not found




If Not sr > 0 Then
    MsgBox "Cannot match that saet.  Please try again"
    On Error GoTo 0
    Exit Sub
End If
    
'Otherwise, test if new seat is occupied by cheking H & I for names ??
If Range("H" & sr) = "" And Range("I" & sr) = "" Then   'seat is not occupied so..
   'surpress screen updates and calculation
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
    'move details
     Range("B" & sr & ":C" & sr).Value = Range("B" & pr & ":C" & pr).Value
     Range("G" & sr & ":I" & sr).Value = Range("G" & pr & ":I" & pr).Value
     
     'Clear old details
     Range("B" & pr & ":C" & pr).ClearContents
     Range("G" & pr & ":I" & pr).ClearContents
     
     
    'reset update and calc
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    'reset cells
    
rw = ActiveCell.Row


    Range("B" & rw) = "Open"
    Range("C" & rw) = ""
    Range("G" & rw) = "Open Slot"
    Range("H" & rw) = ""
    Range("I" & rw) = ""
    Range("J" & rw) = "Open Slot"
    Range("C5").Select
    ActiveCell.FormulaR1C1 = ""
    
    Else    'otherwise..
    
    MsgBox "That seat is occupied.  Please try again."
    On Error GoTo 0
End If




End Sub

 

[Snakehips]

Steve,


I have tweaked your code slightly to hopefully give what you want although your code and your last post appear to give conflicting requirements for J ???

Your use of rw is dodgy as you are setting rw to the row of the Active Cell which could be any old cell you have selected at the time ??
Hence I have used pr which is the row of the person you are moving and is independent of the Active cell.

Sub Move_Seat()


Person = Range("F2")
Seat = Range("H2")


fr = 12  '******edit for your first row  i.e.  data headers row


lr = Cells(Rows.Count, "K").End(xlUp).Row 'last row by testing column K




'Find person row using column J
On Error Resume Next
pr = WorksheetFunction.Match(Person, Range("J" & fr & ":J" & lr), 0) + fr - 1




'Bail out if not found
If Not pr > 0 Then
    MsgBox "Cannot match that name.  Please try again"
    On Error GoTo 0
    Exit Sub
End If




'Find new seat row using column K
sr = WorksheetFunction.Match(Seat, Range("K" & fr & ":K" & lr), 0) + fr - 1




'Bail out if not found


If Not sr > 0 Then
    MsgBox "Cannot match that saet.  Please try again"
    On Error GoTo 0
    Exit Sub
End If
    
'Otherwise, test if new seat is occupied by cheking H & I for names ??
If Range("H" & sr) = "" And Range("I" & sr) = "" Then   'seat is not occupied so..
   'surpress screen updates and calculation
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
    'move details
     Range("B" & sr & ":C" & sr).Value = Range("B" & pr & ":C" & pr).Value
     Range("G" & sr & ":I" & sr).Value = Range("G" & pr & ":I" & pr).Value
     
     'Reset old details
     Range("B" & pr) = "Open"
     Range("C" & pr).ClearContents
     Range("G" & pr) = "Open Slot"
     Range("H" & pr & ":I" & pr).ClearContents
     Range("J" & pr) = "Open Slot"   '???????????  or formula so leave it ?????
     
    '***
    Range("C5").Select
    ActiveCell = ""
    
    'reset update and calc
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
   
    Else    'otherwise..
    
    MsgBox "That seat is occupied.  Please try again."
    On Error GoTo 0
End If


End Sub

 

[Oranjin]

Thank you! I've added a couple of things but this was perfect! You saved the day!

Steve