Excel Help with VBA Code

[FLdave12]

I have a workbook with a master sheet with names and information on. I would like to have all the information in a row from master sheet transferred to specific sheets. The master sheet is called DR Waiting List. Currently, the information transfers to DR Serving List when an X is put in the Add to DR Serve List column.

I would like to have multiple columns in the master sheet (DR Waiting List) to enter a X so that information can be directed to the other sheets called Central Males, North Males, Healthcare, South and Roadcrew. Or if there is another way.

I will attach file when I get a chance. Any advise or assistance is appreciated

 

[Michael M]

You can't attach files in this forum.
I'd suggest uploading the file to a hosting site, then post the link to that file back here.

 

[FLdave12]

Dropbox

www.dropbox.com

Above is access link to workbook. I want to be able to enter X in one of the P--S (Columns Assigned CD, ND, HD, or SD Worker areas) and have all data in that row transfer to sheet that corresponds to CD, ND, HD, or SD. I also want to have the information that was transferred be removed from the Eligible Workers (Master Sheet).

I appreciate any assistance.

 

[FLdave12]

Would like to have a marco perform the transfer of data and removal of data from master sheet

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your Eligible Workers sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter an "x" in columns P:S and press the ENTER key.

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("P:S")) Is Nothing Then Exit Sub
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Select Case Target.Column
        Case Is = 16
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("CD").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
        Case Is = 17
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("ND").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
        Case Is = 18
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("HD").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
        Case Is = 19
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("SD").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
    End Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[FLdave12]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your Eligible Workers sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter an "x" in columns P:S and press the ENTER key.

Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("P:S")) Is Nothing Then Exit Sub
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Select Case Target.Column
        Case Is = 16
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("CD").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
        Case Is = 17
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("ND").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
        Case Is = 18
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("HD").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
        Case Is = 19
            If Target = "x" Then
                Rows(Target.Row).Copy Sheets("SD").Cells(Sheets("CD").Rows.Count, "A").End(xlUp).Offset(1)
                Target.EntireRow.Delete
            End If
    End Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Works great thank you for the help.

 

[mumps]

You are very welcome.