Macro to delete entry in Sheet 2

Hi, abjac,

I have some questions about regarding my understanding of the problem.

I got that you would like an InputBox to enter the name of the person to search for (Iīd preferred an UserForm with a ComboBox or Listbox and a button for that) and you placed an example for the first week in Sheet3. What about the rest of the year? Do you want to consider the whole year or only a given part of it (if so: which part - half a year, a quarter) or only the first week of absence?

If you want to show the whole year you would have to tell me about the placing of the segments, i.e. directly underneath each other (Date/Absence/Date/Absence)? Do you only want to delete or amend as well?

Ciao,
Holger

Hi, abjac,

this is sort of a double thread as you would need to write the contents from Sheet2 to Sheet3 and only after that start deleting possible entries from Sheet3 on Sheet2.

Sub EF938606_a()

'collect the data for one person in Sheet3

Dim varName     As Variant
Dim strName     As String
Dim lngCounter  As Long

strName = InputBox("Type Name to find entry for.?")
If strName = "" Then Exit Sub

With Worksheets("Sheet2")
'  .Unprotect Password:="1111"
  varName = Application.Match(strName, .Range(.Cells(7, 5), .Cells(Rows.Count, 5)), 0)
  If Not IsError(varName) Then
    Application.ScreenUpdating = False
    varName = varName - 1
    If Worksheets("Sheet3").Range("E" & Rows.Count).End(xlUp).Row > 7 Then
      Worksheets("Sheet3").Range("E9:E" & Worksheets("Sheet3").Range("E" & Rows.Count).End(xlUp).Row).EntireRow.Delete
    End If
    For lngCounter = 0 To 51
      If WorksheetFunction.CountBlank(.Range("F" & 7 + varName + lngCounter * 30).Resize(1, 6)) < 6 Then
        .Range("E" & 7 + lngCounter * 30).Resize(2, 7).Copy
        With Worksheets("Sheet3").Range("E" & Rows.Count).End(xlUp).Offset(2, 0)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
        .Range("E" & 7 + varName + lngCounter * 30).Resize(1, 7).Copy
        With Worksheets("Sheet3").Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
      End If
    Next lngCounter
  End If
  
'  .Protect Password:="1111", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Application.ScreenUpdating = True

End Sub

Sub EF938606_b()
'delete the data for one person and one entry in Sheet2

Dim varName     As Variant
Dim varStart    As Variant
Dim strName     As String
Dim lngCounter  As Long

If ActiveSheet.Name <> "Sheet3" Then Exit Sub
strName = Worksheets("Sheet3").Range("E11").Value
If strName = "" Then Exit Sub

If Selection.Count > 1 Then Exit Sub
If Selection = "" Then Exit Sub
If (Selection.Row - 7) Mod 4 <> 0 Then Exit Sub
If Selection.Column < 6 Or Selection.Column > 11 Then Exit Sub

With Worksheets("Sheet2")
  .Unprotect Password:="1111"
  varStart = Application.Match(CDbl(Worksheets("Sheet3").Cells(Selection.Row - 2, "F")), .Columns(6), 0)
  If Not IsError(varStart) Then
    varName = Application.Match(strName, .Range(.Cells(varStart, 5), .Cells(Rows.Count, 5)), 0)
    varName = varName - 1
    If Not IsError(varName) Then
      .Cells(varStart + varName, Selection.Column).ClearContents
    End If
  End If
  .Protect Password:="1111", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

With Selection
  .ClearContents
  .Interior.Pattern = xlNone
End With

End Sub

HTH,
Holger

Hi Holger. Thanks for the codes. I tried your code but cant make it work. The first code find the entry for one person fine. But when i have to delete a entry, i cant make it work. Nothing is running. I dont know if i do it correctly. I made 2 entries for Employe2. I run your macro and it finds the 2 entries perfect.
They are now shown in sheet 3. Then i want to run the other code. I mark the cell or cells with the entry i want to delete in Sheet 3, but nothing seems to be running.
I guess it should work like that. That i can select the cells in sheet 3 i want to delete and it delete the same cells in sheet 2.
Please have a look, when you have time. Or maybe send my test back.
Thanks for now
Sincerely
Abjac

Hi, abjac,

but nothing seems to be running.

Maybe I should have been a bit more specific on the limitations for deleting entries but they are all listed in the code:

If ActiveSheet.Name <> "Sheet3" Then Exit Sub
strName = Worksheets("Sheet3").Range("E11").Value
If strName = "" Then Exit Sub

If Selection.Count > 1 Then Exit Sub
If Selection = "" Then Exit Sub
If (Selection.Row - 7) Mod 4 <> 0 Then Exit Sub
If Selection.Column < 6 Or Selection.Column > 11 Then Exit Sub

The code will ony run if the active Sheet is Sheet3 and one single cell with any reason of absence is marked in Columns F to K in any fourth row starting with Row 11 (11, 15, 19 etc.). Only then the contents of that cell will be deleted from Sheet2 (and after that from Sheet3 as well). I havenīt thought about how to develop a macro that would allow to delete multiple entries from Sheet2 since this one isnīt doing what it is supposed to do (according to your post).

HTH,
Holger

Hi, abjac,

the code for multiple deletion is based on the code for deleting one single entry: the check for the worksheet and the name to search for are still made before any looping through the selected cells is done.

Sub EF938606_b_Multi()
'delete the data for one person and one entry in Sheet2

Dim varName     As Variant
Dim varStart    As Variant
Dim strName     As String
Dim rngCell     As Range
Dim rngArea     As Range

If ActiveSheet.Name <> "Sheet3" Then Exit Sub
strName = Worksheets("Sheet3").Range("E11").Value
If strName = "" Then Exit Sub

For Each rngArea In Selection.Areas
  For Each rngCell In rngArea
    If rngCell.Value <> "" Then
      If (rngCell.Row - 7) Mod 4 = 0 Then
        If rngCell.Column > 5 Or rngCell.Column < 12 Then
          With Worksheets("Sheet2")
            varStart = Application.Match(CDbl(Worksheets("Sheet3").Cells(rngCell.Row - 2, "F")), .Columns(6), 0)
            If Not IsError(varStart) Then
              varName = Application.Match(strName, .Range(.Cells(varStart, 5), .Cells(Rows.Count, 5)), 0)
              varName = varName - 1
              If Not IsError(varName) Then
                .Unprotect Password:="1111"
                .Cells(varStart + varName, rngCell.Column).ClearContents
                .Protect Password:="1111", DrawingObjects:=True, Contents:=True, Scenarios:=True
              End If
            End If
          End With
          With rngCell
            .ClearContents
            .Interior.Pattern = xlNone
          End With
        End If
      End If
    End If
  Next rngCell
Next rngArea

End Sub

Ciao,
Holger