Private Sub Worksheet_Change(ByVal Target As Range)

LastColumn = Worksheets("List2").Cells(1, Columns.Count).End(xlToLeft).Column
     'Block 1
        If Not Intersect(Target, Range("Data").Columns(1)) Is Nothing Then
            On Error Resume Next
                           If WorksheetFunction.CountIf(Worksheets("List2").Range("Masters"), Target) = 0 Then
                    lReply = MsgBox("Do you want to add " & Target & " to dropdown list?", vbYesNo + vbQuestion)
                        If lReply = vbYes Then
                        With Worksheets("List2")
                            .Range("Masters").Cells(.Range("Masters").Rows.Count + 1, 1) = Target
                            .Cells(1, LastColumn + 1) = Target
                            .Columns.AutoFit
                                          
                        End With
                        End If
                End If
                End If
                
     'Block 2
     
            Position = WorksheetFunction.Match(Target.Offset(0, -1).Value, Worksheets("List2").Rows(1), 0)
            LastRow = Worksheets("List2").Cells(Rows.Count, Position).End(xlUp).Row
        
                
                If Not Intersect(Target, Range("Data").Columns(2)) Is Nothing Then
            On Error Resume Next
                           If WorksheetFunction.CountIf(Worksheets("List2").Range(Cells(2, Position), Cells(LastRow, Position)), Target) = 0 Then
                    lReply = MsgBox("Do you want to add " & Target & " to dropdown list?", vbYesNo + vbQuestion)
                        If lReply = vbYes Then
                        With Worksheets("List2")
                           .Cells(LastRow + 1, Position) = Target
                           .Columns.AutoFit
                                          
                        End With
                        End If
                End If
                End If
                
End Sub 

Sub RangeCheck()
Dim cell As Range
Dim Counter As Long
Counter = 0
For Each cell In Range("Data").Columns(3)
If Not IsEmpty(cell) Then
  If Date - cell.Value > 50 And Date - cell.Value < 60 Then
    If cell.Offset(0, 3).Value = "" And cell.Offset(0, 6) = "" And cell.Offset(0, 9).Value = "" Then
      MsgBox "Deadline is coming", vbInformation
      Counter = Counter + 1
      cell.Activate
     Else
    MsgBox "Everything is OK"
    End If
  End If
End If
Next cell
MsgBox Counter & " record(s) were found."
End Sub

Sub ReverseRange()
Dim x As Variant
Dim r As Long, c As Integer
x = Selection.Value
For r = 1 To UBound(x, 1)
For c = 1 To UBound(x, 2)
x(r, c) = x(Abs(r - (Selection.Rows.Count+1)), c)
Next c
Next r
Selection = x
End Sub

Sub RedDog()
Dim cell As Range
If TypeName(Selection) <> "Range" Then Exit Sub
For Each cell In Selection
If LCase(cell.Value) = "dog" Then
cell.Font.Color = RGB(255, 0, 0)
End If
Next cell
End Sub

Sub AddNewSheet()
    Dim ShtName As String, NewName As String
    Dim i As Long
    Dim MySH As Worksheet
    
    ShtName = Format(Date, "dd.mm.yy")
    On Error Resume Next
       
        Set MySH = Sheets(ShtName)
        If MySH Is Nothing Then
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = ShtName
        Else
            NewName = InputBox("This sheet already exists.")
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = NewName
        End If
End Sub

Sub AddSheet()
Dim ShtName As String
Dim i As Long
Dim NSheet As Worksheet
ShtName = Format(Date, "dd.mm.yy")
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name = ShtName Then Exit Sub
Next i
Sheets.Add(After:=Sheets(Sheets.Count)).Name = ShtName
End Sub

Sub AddSheet()
Dim ShtName As String
ShtName = Format(Date, "dd.mm.yy")
On Error Resume Next
Sheets.Add(After:=Sheets(Worksheets.Count)).Name = ShtName
Sheets(1).Activate
On Error GoTo 0
End Sub

Sub AddSheet()
Dim i As Long
Dim ShtName As String
ShtName = Format(Date, "dd.mm.yy" ;) 
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = ShtName
End Sub

[/CODE]
Sub AddSheet()
Dim ShtName As String
Dim i As Long


ShtName = Format(Date, "dd.mm.yy")
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Name <> Sheets(ShtName) Then
Sheets(ShtName).Add After:=Sheets(1)
End If
Next i
End Sub
[CODE]

Sub BubbleSort(List() As String)
‘ Sorts the List array in ascending order
 Dim First As Long, Last As Long
 Dim i As Long, j As Long
 Dim Temp As String
 First = LBound(List)
 Last = UBound(List)
 For i = First To Last - 1
 For j = i + 1 To Last
 If List(i) > List(j) Then
 [B]Temp = List(j)
 List(j) = List(i)
 List(i) = Temp[/B]
 End If
 Next j
 Next i
End Sub