Sub qqq()

    Range("G5:G11").Select
    Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

Windows(Nom3).Close False 'закрыть книгу 2

Sub Мой()
MsgBox "ВНИМАНИЕ! Убедитесь что лист с прайсом в файле называется artikelimport hulp v2.2"
With Application
.Calculation = xlManual
.ScreenUpdating = False
End With
Dim a, B As Variant, Nom, Nom2 As String 'Описываем переменные
    Nom = ActiveWorkbook.Name 'Задаем имя активной книге
    ChDrive "C:"    'Выбор диска
    ChDir "C:\"    'Выбор каталога
        a = Application.GetOpenFilename("Тип файла (*.xlsx), *.xlsx", _
                                    , "Выберите свой прайс", , True) 'выбираем тип файлов excel
        Select Case TypeName(a)
        Case Is = "Boolean"
            Exit Sub
        Case Else
            For B = LBound(a) To UBound(a)
                Workbooks.Open a(B), CorruptLoad:=xlExtractData 'проверка выбора excel
            Next
        End Select
    Nom3 = ActiveWorkbook.Name 'задаем имя 2-й книге
    Sheets("artikelimport hulp v2.2").Activate 'Выбрать лист
    Cells.Select
    Selection.Copy 'Копировать выделеное
    Windows(Nom).Activate 'активировать книгу1
    Лист2.Visible = True 'отобразить лист
    Лист2.Activate 'Выбрать лист
    Cells.Select
'    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
Application.DisplayAlerts = False 'скрыть сообщения об ошибке
Windows(Nom3).Close False 'закрыть книгу 2

Лист3.Select 'выбрать лист

    Лист2.Visible = 2 'Скрыть лист
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With 'Включить обновление экрана
MsgBox ("Прайс поставщика загружен"), 64, "InternetStore" 'Сообщение о выполнении
End Sub

Option Explicit
Private Sub Button1_Click()
With Application
.Calculation = xlManual
'.ScreenUpdating = False
End With
Dim a, B As Variant, Nom, Nom2 As String 'Описываем переменные
    Nom = ActiveWorkbook.Name 'Задаем имя активной книге
    ChDrive "C:"    'Выбор диска
    ChDir "C:\"    'Выбор каталога
        a = Application.GetOpenFilename("Тип файла (*.csv), *.csv", _
                                    , "Выберите отчет QUIZZ", , True) 'выбираем тип файлов excel
        Select Case TypeName(a)
        Case Is = "Boolean"
            Exit Sub
        Case Else
            For B = LBound(a) To UBound(a)
                Workbooks.Open a(B)
'                Workbooks.Open a(B), CorruptLoad:=xlExtractData 'проверка выбора excel
            Next
        End Select
    Nom2 = ActiveWorkbook.Name 'задаем имя 2-й книге
Columns("A:A").Select
            Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
                ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
                (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1)), TrailingMinusNumbers _
                :=True
End Sub

 Columns("A:A").Select

    Range("A3: " & RngLR & ").Select

      LR = Cells(Rows.Count, 1).End(xlUp).Row
        RngLR = "A" & LR
        Range("A3:P3").Select
    Selection.Copy
    Range("A3: " & RngLR & ").Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

If Sheets("Start").ComboBox1 = "" Then
MsgBox ("Выберите отдел!" & Chr(10) & Chr(10) & "Или значение ''Общий итог''"), 48 'Сообшение
Else
'ALL_Forms.Hide
'Application.ScreenUpdating = False 'Отключить обновление экрана
Sheets("Руптюры магазина").Visible = True
Sheets("Руптюры магазина").Activate 'Активировать лист
ActiveSheet.PivotTables("Руптюры").PivotFields("Смена").ClearAllFilters 'очистить фильтр сводной таблисы
ActiveSheet.PivotTables("Руптюры").PivotFields("Смена").CurrentPage = ALL_Forms.ComboBox3.Value ' Задать фильтр сводной по значению из комбобокса
ActiveSheet.PivotTables("Руптюры").PivotFields("Отдел").ShowDetail = False 'скрыть детали сводной таблицы
ActiveSheet.PivotTables("Руптюры").PivotCache.Refresh
Dim r As Range, t, Y As Integer
Set Z = ThisWorkbook.Sheets("Руптюры магазина").Range("A5:A150").Find(Sheets("Start").ComboBox1.Value, , xlFormulas, xlPart)
'Set v = ThisWorkbook.Sheets("Руптюры магазина").Range("A4:H4").Find("Общий итог", , xlFormulas, xlPart)
Set v = ThisWorkbook.Sheets("Руптюры магазина").Range("A4:H4").Find(ALL_Forms.ComboBox4.Value, , xlFormulas, xlPart)
Y = Z.Row
t = v.Column
Set r = Cells(Y, t)
r.Select
Selection.ShowDetail = True 'раскрыть детали сводной таблицы
Печать
'ALL_Forms.ComboBox2.Clear
'ALL_Forms.ComboBox3.Clear
ALL_Forms.ComboBox4.Clear

Columns(20).Clear
Range("A5:A40").Select
Selection.Copy
Range("T1:T35").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
[T1].Sort [T1], xlAscending, Header:=xlNo
Set s = Columns(20).SpecialCells(xlCellTypeConstants)
ALL_Forms.ComboBox2.List = s.Value

' ALL_Forms.ComboBox3.AddItem "1 смена"
' ALL_Forms.ComboBox3.AddItem "2 смена"
' ALL_Forms.ComboBox3.AddItem "ОЗКУ"
'  ALL_Forms.ComboBox3.AddItem "Все"
 ALL_Forms.ComboBox4.AddItem "1. Недостаточный заказ"
 ALL_Forms.ComboBox4.AddItem "2. Неактив NA"
 ALL_Forms.ComboBox4.AddItem "3. Проверьте наличие товара"
 ALL_Forms.ComboBox4.AddItem "4. Задержка поставки"
  ALL_Forms.ComboBox4.AddItem "Общий итог"

'ALL_Forms.ComboBox2.Text = "Общий итог"
'ALL_Forms.ComboBox3.Text = "Все"
ALL_Forms.ComboBox4.Text = "Общий итог"

Sheets("Руптюры магазина").Visible = 2
End If
Application.ScreenUpdating = True 'Включить обновление экрана
inform = ThisWorkbook.Sheets("BIP").Cells(1, 3)

Set Z = ThisWorkbook.Sheets("Руптюры магазина").Range("A5:A150").Find(Sheets("Start").ComboBox1.Value, , xlFormulas, xlPart)

Function DateFind(rng As Range, Optional FindFirst As Boolean = True)
Dim x As Range
       For Each x In rng
        If IsDate(x) Then
           DateFind = x
           If FindFirst Then Exit Function
        End If
    Next
    DateFind = "нет"
End Function

=DateFind(A:A)

=DateFind(A:A;ЛОЖЬ)

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Declare Function GetCursorPos _
    Lib "user32.ddl" (IpPoint As POINTAPI) As Long
Sub Auto_Open()
GetCursorPosition
End Sub

Private Sub GetCursorPosition()
Dim oPOINT As POINTAPI, pauseTime, Start, Finish, TotalTime
Application.DisplayAlerts = True 'Разрешаем предупреждения на время работы

GetCursorPos IPoint 'запрашиваем позицию курсора
Xx = IPoint.X
Yy = IPoint.Y

pauseTime = 10 ' время в секундах

Start = Timer 'Старт
Do While Timer < Start + pauseTime 'Запускаем цикл таймера
DoEvents 'Выход на другие процессы
Loop
Finish = Timer 'Время вышло
TotalTime = Finish - Start 'Подсчет времени простоя
GetCursorPos IPoint 'Запрашиваем позицию курсора
Xx2 = IPoint.X
Yy2 = IPoint.Y

If Xx = Xx2 And Yy = Yy2 Then 'Сравниваем 1 и 2 положение курсора
'Начинаем действия при простое
If ActiveWorkbook.ReadOnly Then 'проверяем файл на "Только чтение"
Excel.ActiveSheet.Cells(1, 1).Select 'переходим на ячейку 1,1 для устранения не оконченного ввода
Application.DisplayAlerts = False 'подавляем предупреждения
Aplication.Quit ' Закрываем приложение
ActiveWorkbook.Close True
Application.DisplayAlerts = True 'Разрешаем предупреждения на время работы
Else
Application.DisplayAlerts = False 'подавляем предупреждения
Excel.ActiveWorkbook.Save 'сохраняем активную книгу
Aplication.Quit ' Закрываем приложение
ActiveWorkbook.Close True
Application.DisplayAlerts = True 'Разрешаем предупреждения на время работы
End If
End
Else
'тут пользователь двигал курсор
End If
cicle 'переходим к процедуре цикла
End Sub
Private Sub cicle()
GetCursorPosition 'Зацикливаем процедуру пока не будет бездействия юзера
End Sub

With ActiveSheet.PageSetup
        .LeftHeader = "&20 Page &P de &N"
End With

  With ActiveSheet.PageSetup
        .LeftHeader = Range("B2")
  End With

Dim d(), c&, cs&, k$, r&, rs&, X& 'проверка на наличие дубликатов в заданом диапазоне
d = ActiveSheet.Range("AA:AA").Value
ReDim P(1 To UBound(d, 1), 1 To UBound(d, 2))
rs = UBound(d, 1)
cs = UBound(d, 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For r = 1 To rs
For c = 1 To cs
k = Trim(d(r, c))
If Len(k) Then
If .Exists(k) Then
P(r, c) = d(r, c)
X = X + 1
Else
.Add k, 0
End If
End If
Next
Next
End With
ActiveSheet.Range("AB:AB").Resize(UBound(P)).Value = P()

Public Sub CommandButton1_Click()
Dim FN, FP  As Range, WB As String
    WB = ActiveWorkbook.Name
    FN = Sheets("Navigation").Range("D1")
    Set FP = Range("A1")
For i = 1 To 7
    ChDir FP
        Workbooks.Open Filename:=FP & FN 
            Sheets("Report1Data").Select 
            Range("A:S").Select 
            Selection.Copy 
    Windows(WB).Activate 
            Sheets("Поставки").Select 
            Range("A1").Select 
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
    With Application
        .CutCopyMode = False 
        .DisplayAlerts = False
    End With
    Windows(FN).Close False 
Var = "D" & i 
FN = Sheets("Navigation").Range("& Var &")
Next
End Sub

Public Sub CommandButton1_Click()
   
Dim FN, FP  As Range, WB, WB2 As String
    WB = ActiveWorkbook.Name
    FN = Sheets("Navigation").Range("D1")
    Set FP = Range("A1")
ChDir FP
    Workbooks.Open Filename:=FP & FN

End Sub