Sub UpdateTime_real()
  Dim varNextCall As Variant   ' Записываем в ячейку текущее время
     Cells(1, 13).Value = Now  ' Записываем в varNextCall время, когда вызвать этот макрос в следующий раз (через 1 секунду)
     varNextCall = TimeSerial(Hour(Now), Minute(Now), Second(Now) + 1) ' Уведомляем Excel в необходимости вызова макроса
     
     Cells(1, 14).Value = Now   ' Записываем в varNextCall время, когда вызвать этот макросв следующий раз (через 1 секунду)
     varNextCall = TimeSerial(Hour(Now), Minute(Now), Second(Now) + 1) ' Уведомляем Excel в необходимости вызова макроса
End Sub

 Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
    
    
        'открываем книгу
        Workbooks.Open sFolder & sFiles
        
        'действия с файлом
        
        'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru
        ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub

Sub копирование_последнего_и_1справа_столбцов()
Dim lRow As Long
Dim lCol As Long
lRow = Cells(Rows.count, 1).End(xlUp).Row
lCol = Cells(6, Columns.count).End(xlToLeft).Column

MsgBox "Последняя строка: " & lRow & vbNewLine & _
"Последний столбец: " & lCol

Range(Columns(lCol), Columns(lCol + 1)).EntireColumn.Select
Selection.Copy
'Range(Columns(lCol), Columns(lCol + 1)).EntireColumn.Copy
Sheets("имя_листа2").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
'ActiveSheet.Paste


End Sub

'в этом месте надо как то вставить код чтоб он искал в списке женское имя и если находил то далее снятие защиты и ....
    ActiveSheet.Unprotect
    Range("A8:B8,D8:L8").Select
    Range("D8").Activate
    Selection.ClearContents
    Selection.Locked = False
    Selection.FormulaHidden = False
    Range("C9").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True
End Sub[CODE][/CODE]

Sub AddRecordsByFieldValue(StartRow As Integer, ColumnNumber As Integer)

i = StartRow
Do
If Cells(i, ColumnNumber).Value <> 0 Then
NumberOfRowToInsert = Cells(i, ColumnNumber).Value
For j = 1 To NumberOfRowToInsert
Cells(i + j, ColumnNumber).Select
Selection.Insert Shift:=xlDown
Next
i = i + j
Else
Exit Do
End If
Loop

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Call AddRecordsByFieldValue(ActiveCell.Row, ActiveCell.Column)

End Sub