Thread: Macro to select first cell under each heading

I have a worksheet with different categories of employees (i.e. Project Geologist, Project Manager etc.). Each category has a heading with an “Add New Employee” macro button. When the macro runs, a popup asks for the name of the new employee to be entered and then it places that name in cell B7. Trouble is, I need it to enter the new name under the appropriate heading, not always to the default B7. EXAMPLE - for the “Add Project Manager” macro button, the new name would need to go in the first cell in column B under the “Project Manager” heading. Can you provide code to place the new name in the first cell in column B under the appropriate heading containing the button? Once one is figured out, I’m sure I can correct the rest below it.

The full code is located in the attached example, but for quick viewing, here is the popup portion of the code placing the name into cell B7:

Code:

Dim response As Variant
    response = Application.InputBox("Enter name of new employee")
    If response = 0 Then
        Exit Sub
    ElseIf response <> "" Then
    Range("B7").Select
    ActiveCell.FormulaR1C1 = response
        End If

Something like this:

Code:

Sub Add_PM()
Dim EmpRow As Long
Application.ScreenUpdating = False
    
EmpRow = Range("A:A").Find(What:="PROJECT MANAGER", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, _
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row

    Rows(EmpRow).Copy
    Rows(EmpRow).Insert Shift:=xlDown
    Rows(EmpRow).ClearContents
    
    Range("C12").Select
    Selection.AutoFill Destination:=Range("C11:C12"), Type:=xlFillDefault
    
    Dim response As String
    response = Application.InputBox("Enter name of new employee", Type:=8)
    If response = 0 Then Exit Sub
    If response <> "" Then Range("B" & EmpRow + 1) = response

The new variable EmpRow is a number, so you can adjust it mathematically do things in adjacent rows (e.g. EmpRow + 1)

In your later code, there is much opportunity to eliminate selecting...read through this and compare to your original code, this will function much more rapidly.

Code:

Sub Add_PG()
    
    Rows("7:7").Copy
    Range("A7").Insert xlShiftDown
    Rows("7:7").ClearContents
    
    Range("C8").Select
    Selection.AutoFill Destination:=Range("C7:C8"), Type:=xlFillDefault
      
    Dim response As Variant
    response = Application.InputBox("Enter name of new employee")
    If response = 0 Then Exit Sub
    If response <> "" Then Range("B7").FormulaR1C1 = response
    
    Sheets("Employees").Select
    Rows("2:2").Copy
    Range("A2").Insert xlShiftDown
    Range("A2").FormulaR1C1 = "='Budget Daily'!R[5]C[1]"
    Range("D2").FormulaR1C1 = "='Budget Summary'!R[5]C[-2]"
    Range("E2").FormulaR1C1 = "=R[1]C+1"
    Range("H2").FormulaR1C1 = "='Budget Summary'!R[5]C[-3]"
    
    Sheets("Employee Profile").Select
    Range("A4:P21").Copy
    Range("A4").Insert xlShiftDown
    Range("B5").FormulaR1C1 = "=Employees!R[-3]C[-1]"
    Range("D8:G8").FormulaR1C1 = "=Employees!R[-6]C[1]"
    Range("D9:G9").FormulaR1C1 = "=Employees!R[-7]C[3]"
    Range("D10:G10").FormulaR1C1 = "=Employees!R[-8]C"
    Range("D11:G11").FormulaR1C1 = "=Employees!R[-9]C[4]"
    Range("D12:G12").FormulaR1C1 = "=Employees!R[-10]C[7]"
    Range("D13:G13").FormulaR1C1 = "=Employees!R[-11]C[8]"
    Range("D14:G14").FormulaR1C1 = "=Employees!R[-12]C[9]"
    Range("D15:G15").FormulaR1C1 = "=Employees!R[-13]C[10]"
    Range("D16:G16").FormulaR1C1 = "=Employees!R[-14]C[5]"
    Range("D17:G17").FormulaR1C1 = "=Employees!R[-15]C[6]"
    Range("D18:G18").FormulaR1C1 = "=Employees!R[-16]C[23]"
    Range("D19:G19").FormulaR1C1 = "=Employees!R[-17]C[24]"
    Range("K8:N8").FormulaR1C1 = "=Employees!R[-6]C[4]"
    Range("K9:N9").FormulaR1C1 = "=Employees!R[-7]C[5]"
    Range("K10").FormulaR1C1 = "=Employees!R[-8]C[6]"
    Range("L10:N10").FormulaR1C1 = "=Employees!R[-8]C[6]"
    Range("K11:N11").FormulaR1C1 = "=Employees!R[-9]C[8]"
    Range("K12:N12").FormulaR1C1 = "=Employees!R[-10]C[9]"
    Range("K13:N13").FormulaR1C1 = "=Employees!R[-11]C[10]"
    Range("K14:N14").FormulaR1C1 = "=Employees!R[-12]C[11]"
    Range("K15:N15").FormulaR1C1 = "=Employees!R[-13]C[12]"
    Range("K16:N16").FormulaR1C1 = "=Employees!R[-14]C[14]"
    Range("K16:N16").FormulaR1C1 = "=Employees!R[-14]C[13]"
    Range("K17:N17").FormulaR1C1 = "=Employees!R[-15]C[14]"
    Range("K18:N18").FormulaR1C1 = "=Employees!R[-16]C[15]"
    Range("K19:N19").FormulaR1C1 = "=Employees!R[-17]C[-5]"
    
    Sheets("Project Schedule").Select
    Rows("18:18").Copy
    Range("A18").Insert xlShiftDown
    Rows("18:18").ClearContents
    Range("A18").FormulaR1C1 = "=Employees!R[-16]C"
    Range("CD19:CF19").AutoFill Destination:=Range("CD18:CF19"), Type:=xlFillDefault
    Range("CD18:CF19").Select
    
    Sheets("Travel").Select
    Range("B2").FormulaR1C1 = _
        "=IF(RC1="""","""",INDEX(Employees!R2C30:R83C30,MATCH(RC1,Employees!R2C1:R83C1,0)))"
    Range("B2").AutoFill Destination:=Range("B2:B17"), Type:=xlFillDefault
    Range("B22").FormulaR1C1 = _
        "=IF(RC1="""","""",INDEX(Employees!R2C30:R83C30,MATCH(RC1,Employees!R2C1:R83C1,0)))"
    Range("B22").AutoFill Destination:=Range("B22:B37"), Type:=xlFillDefault
    Range("B22:B37").Select
    Workbooks.Open Filename:= _
        "C:\Documents and Settings\colins\Desktop\ProjectManager\Timesheet.xlsm"
        
    Sheets("Timesheet").Select
    Sheets("Timesheet").Copy After:=Sheets(1)
    
    
    Windows("ProjectManager.xlsm").Activate
    Sheets("Budget Daily").Activate
    Range("B7").Copy
    Windows("Timesheet.xlsm").Activate
    Range("C3").PasteSpecial xlPasteValues
    
    ActiveSheet.Name = Range("C3").Value

    ActiveWorkbook.Save
    ActiveWindow.Close

Application.ScreenUpdating = True
End Sub

Have a look through this, a lot of changes... using the RESPONSE all through the code to insert the name directly.

I really think you can use an INDEX/MATCH formula in the Employee Profile section so you don't have to change the links, all you have to do is insert the new name into B5 and the other values will update correctly with the formulas already there. For instance, in D8:

=INDEX(Employees!E:E, MATCH(B5, Employees!$A:$A, 0))

Using those formulas lets you cut out a whole section of that macro.

On the Project and Budget sheets, we're no longer delete entire row contents then having to put some formulas back, we're just deleting the stuff that needs deleting.

Code:

Sub Add_PG()
Dim EmpRow As Long
Application.ScreenUpdating = False
    
EmpRow = Range("A:A").Find(What:="PROJECT GEOLOGIST", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, _
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row + 1

    Rows(EmpRow).Copy
    Range("A" & EmpRow).Insert xlShiftDown
    Range("E" & EmpRow, Cells(EmpRow, Columns.Count)).ClearContents
    
    Dim response As Variant
    response = Application.InputBox("Enter name of new employee")
    If response = 0 Then Exit Sub
    If response <> "" Then Range("B" & EmpRow) = response
    
With Sheets("Employees")
    .Rows("2:2").Copy
    .Range("A2").Insert xlShiftDown
    .Range("A2") = response
    .Range("D2").FormulaR1C1 = "='Budget Summary'!R7C2"
    .Range("E2") = Application.WorksheetFunction.Max(.Range("E:E")) + 1
    .Range("H2").FormulaR1C1 = "='Budget Summary'!R7C5"
End With

With Sheets("Employee Profile")
    .Range("A4:P21").Copy
    .Range("A4").Insert xlShiftDown
    .Range("B5") = response
    .Range("D8").FormulaR1C1 = "=Employees!R[-6]C[1]"    'all this can be eliminated with INDEX/MATCH formulas on the sheet instead
    .Range("D9:G9").FormulaR1C1 = "=Employees!R[-7]C[3]"
    .Range("D10").FormulaR1C1 = "=Employees!R[-8]C"
    .Range("D11").FormulaR1C1 = "=Employees!R[-9]C[4]"
    .Range("D12").FormulaR1C1 = "=Employees!R[-10]C[7]"
    .Range("D13").FormulaR1C1 = "=Employees!R[-11]C[8]"
    .Range("D14").FormulaR1C1 = "=Employees!R[-12]C[9]"
    .Range("D15").FormulaR1C1 = "=Employees!R[-13]C[10]"
    .Range("D16").FormulaR1C1 = "=Employees!R[-14]C[5]"
    .Range("D17").FormulaR1C1 = "=Employees!R[-15]C[6]"
    .Range("D18").FormulaR1C1 = "=Employees!R[-16]C[23]"
    .Range("D19").FormulaR1C1 = "=Employees!R[-17]C[24]"
    .Range("K8").FormulaR1C1 = "=Employees!R[-6]C[4]"
    .Range("K9").FormulaR1C1 = "=Employees!R[-7]C[5]"
    .Range("K10").FormulaR1C1 = "=Employees!R[-8]C[6]"
    .Range("L10").FormulaR1C1 = "=Employees!R[-8]C[6]"
    .Range("K11").FormulaR1C1 = "=Employees!R[-9]C[8]"
    .Range("K12").FormulaR1C1 = "=Employees!R[-10]C[9]"
    .Range("K13").FormulaR1C1 = "=Employees!R[-11]C[10]"
    .Range("K14").FormulaR1C1 = "=Employees!R[-12]C[11]"
    .Range("K15").FormulaR1C1 = "=Employees!R[-13]C[12]"
    .Range("K16").FormulaR1C1 = "=Employees!R[-14]C[14]"
    .Range("K16").FormulaR1C1 = "=Employees!R[-14]C[13]"
    .Range("K17").FormulaR1C1 = "=Employees!R[-15]C[14]"
    .Range("K18").FormulaR1C1 = "=Employees!R[-16]C[15]"
    .Range("K19").FormulaR1C1 = "=Employees!R[-17]C[-5]"
End With

With Sheets("Project Schedule")
    EmpRow = .Range("A:A").Find(What:="PROJECT GEOLOGIST", After:=.[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row + 2
    .Rows(EmpRow).Copy
    .Range("A" & EmpRow).Insert xlShiftDown
    .Range("B" & EmpRow, .Cells(EmpRow, "CB")).ClearContents
    .Range("A18") = response
End With

With Sheets("Travel")
    .Range("B2").FormulaR1C1 = _
        "=IF(RC1="""","""",INDEX(Employees!R2C30:R83C30,MATCH(RC1,Employees!R2C1:R83C1,0)))"
    .Range("B2").AutoFill Destination:=.Range("B2:B17"), Type:=xlFillDefault
    .Range("B22").FormulaR1C1 = _
        "=IF(RC1="""","""",INDEX(Employees!R2C30:R83C30,MATCH(RC1,Employees!R2C1:R83C1,0)))"
    .Range("B22").AutoFill Destination:=.Range("B22:B37"), Type:=xlFillDefault
End With

    Workbooks.Open Filename:= _
        "C:\Documents and Settings\colins\Desktop\ProjectManager\Timesheet.xlsm"
        
    Sheets("Timesheet").Copy After:=Sheets(1)
    Range("C3") = response
    
    ActiveSheet.Name = response
    ActiveWorkbook.Save
    ActiveWindow.Close

Application.ScreenUpdating = True
End Sub

You'll notice, I've pretty much removed all the selecting that the macro recorder records. It's recording your human activity, so since you select a cell then enter a formula, it shows that. But you can always merge those multi-step lines of recorded "selection" code into one direct VBA command:

Code:

Range("A1").Select
Selection.FormulaR1C1 = "Totals"
Range("A2").Select
Selection.FormulaR1C1 = "=SUM(C2)"

...becomes

Range("A1") = "Totals"     'text, not even a formula, so took out the R1C1 reference
Range("A2").FormulaR1C1 = "=SUM(C2)"

Turning off ScreenUpdating allows the code to execute WAY faster, too.

Also, instead of activating a sheet, use the With Sheet syntax simply address your following commands directly to that sheet without ever going there.

I would upload the sheet, but many of your Excel 2007 formulas broke when I opened the sheet, so I'll have to just answer your questions here. Please don't private message thread content questions.

I made a couple of tweaks to the "Travel" section above, so you may want to grab the code again.

Also, I've just ran it 5 times in a row to add 5 employees and it works for me. If this line is giving you a problem, perhaps this:

Code:

With Sheets("Project Schedule")
    EmpRow = .Range("A:A").Find(What:="PROJECT GEOLOGIST", After:=.Range("A1"), _
        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row + 2

If that still doesn't work, then I would think the code is actually failing to find the search string on your sheet. Check the Project Schedule and make sure Project Geologist is in column A to be found.

Hehe, I forgot I had fixed that on my copy. I set the range so that it started above the existing rows and ended below, this insures it expands when you insert INSIDE the range. In D8:

=SUM(C6:C8)

Not in the code, put the formula in cell D8 on the worksheet. The goal here is a worksheet formula that updates itself without VBA needing to do anything, like we did with the INDEX/MATCH formulas.

Put that formula in D8. See how it starts above the range and ends below it? Now if your macro inserts a row inside the range, cell D8 will move down D9 and update itself.

A project like yours, I would go modular. You're doing very similar, perhaps identical things on various sheet based on each employee type you're adding. So I would take each of the "update tasks" and make them a sub of their own.

Then I would create a master index of those subs and call each one needed.

You can pass variables between subs, so you could feed the job type directly into the subs.

In fact, structured well, you might find the that the macro that STARTS each different employee type might be a simple one liner!

Take a look here:

Code:

Option Explicit
Global Response As String

Sub Add_PM()
    Call Add_Index("PROJECT MANAGER", 2)    '2nd parameter is the offset from the title on the Project Schedule
End Sub

Sub Add_PG()
    Call Add_Index("PROJECT GEOLOGIST", 2)
End Sub

Sub Add_Geologist()
    Call Add_Index("GEOLOGIST", 1)
End Sub

Sub Add_Index(Job As String, Adj As Long)
    Response = Application.InputBox("Enter name of new employee", Type:=2)
    If Response = "False" Then Exit Sub
    
    Application.ScreenUpdating = False
        Call Add_BudgetDaily(Job)
        Call Add_Employee(Job)
        Call Add_Employee_Profile
        Call Add_Project_Schedule(Job, Adj) '2nd parameter is the offset from the title
        Call Add_Travel
        Call Add_TimeSheet
    Application.ScreenUpdating = True

End Sub

Sub Add_BudgetDaily(Job As String)
Dim EmpRow As Long
    With Sheets("Budget Daily")
        EmpRow = .Range("A:A").Find(What:=Job, After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row + 1
        .Rows(EmpRow).Copy
        .Range("A" & EmpRow).Insert xlShiftDown
        .Range("B" & EmpRow + 1) = Response
        .Range("E" & EmpRow, .Cells(EmpRow, Columns.Count)).ClearContents
    End With
End Sub

Sub Add_Employee(Job As String)
    With Sheets("Employees")
        .Rows("2:2").Copy
        .Range("A2").Insert Shift:=xlDown
        .Range("A2") = Response
        .Range("D2") = Job
        .Range("E2") = Application.WorksheetFunction.Max(.Range("E:E")) + 1
        .Range("H2").FormulaR1C1 = "=INDEX('Budget Summary'!C5, MATCH(RC4, 'Budget Summary'!C2, 0))"
    End With
End Sub
Sub Add_Employee_Profile()
    With Sheets("Employee Profile")
        .Range("A4:P21").Copy
        .Range("A4").Insert xlShiftDown
        .Range("B5") = Response
    End With
End Sub
    
Sub Add_Project_Schedule(Job As String, Adj As Long)
Dim EmpRow As Long
    With Sheets("Project Schedule")
        EmpRow = .Range("A:A").Find(What:=Job, After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row + Adj
        .Rows(EmpRow).Copy
        .Range("A" & EmpRow).Insert xlShiftDown
        .Range("B" & EmpRow, .Cells(EmpRow, "CB")).ClearContents
        .Range("A" & EmpRow) = Response
    End With
End Sub

Sub Add_Travel()
    With Sheets("Travel")
        .Range("B2").FormulaR1C1 = _
            "=IF(RC1="""","""",INDEX(Employees!R2C30:R83C30,MATCH(RC1,Employees!R2C1:R83C1,0)))"
        .Range("B2").AutoFill Destination:=.Range("B2:B17"), Type:=xlFillDefault
        .Range("B22").FormulaR1C1 = _
            "=IF(RC1="""","""",INDEX(Employees!R2C30:R83C30,MATCH(RC1,Employees!R2C1:R83C1,0)))"
        .Range("B22").AutoFill Destination:=.Range("B22:B37"), Type:=xlFillDefault
    End With
End Sub

Sub Add_TimeSheet()
    Workbooks.Open Filename:= _
        "C:\Documents and Settings\colins\Desktop\ProjectManager\Timesheet.xlsm"
     
    Sheets("Timesheet").Copy After:=Sheets(1)
    Range("C3") = Response
    
    ActiveSheet.Name = Response
    ActiveWorkbook.Save
    ActiveWindow.Close
End Sub

Any new job types you add that will run ALL the pieces, just create a one-liner to feed into the Add_Index sub. But if you find you're only going to run "part" of the subs on a less important job, create a sub with a shorter index just for that job.

The most important benefit of this modular approach is that if you decide to handle ONE sheet differently, you only have to edit that one sub for that portion. When done, all the subs will use this new version so basically ALL subs are updated.

Here's the sheet when I was done. I also added a lot of those INDEX/MATCH formulas on the first sheet, as well.

The only problem I saw is when you try to use this technique to add GEOLOGIST, it's matched into into PROJECT GEOLOGIST, so I had to go to whole-cell matches on the Project Schedule and make the job types match exactly (no plurals).

So creating a new job is as easy as adding the one liner.

Your changes have simplified the entire process and made everything run much more smoothly. Thanks very much for the help.

Can one more line be added in the last sub? I need to place the job title of the new employee in cell "C4" of the new timesheet worksheet (under the employee name). This can be referenced from "Employees worksheet, D2"

Code:

Sub Add_TimeSheet()
    Workbooks.Open Filename:= _
        "C:\Documents and Settings\colins\Desktop\ProjectManager\Timesheet.xlsm"
     
    Sheets("Timesheet").Copy After:=Sheets(1)
    Range("C3") = Response
    
    ActiveSheet.Name = Response
    ActiveWorkbook.Save
    ActiveWindow.Close
End Sub