Option Private Module




Sub Удалить_Пустоты() ' перебор ячеек диапазона в поисках значения "ТекстДляПоиска"

    Dim cell As Range, delra As Range, ТекстДляПоиска As String
    Application.ScreenUpdating = False
 
    ТекстДляПоиска = ""
 
    For Each cell In Range("C1:C50000").Cells
        If cell = ТекстДляПоиска Then
            If delra Is Nothing Then Set delra = cell Else Set delra = Union(delra, cell)
        End If
    Next

'Это если подходящие строки найдены - удаляем их
    If Not delra Is Nothing Then delra.EntireRow.Delete
    End Sub
Sub дубли()
'

   Range("A2:N50000").Select
    ActiveSheet.Range("$A$3:$N$50000").RemoveDuplicates Columns:=3, Header:= _
        xlYes
End Sub

Private Sub CommandButton1_Click()
  If MsgBox("Напечатать загруженный диапазон?", vbYesNo) = vbNo Then
     Exit Sub
  Else
 ' Шрифт белый
    Nav = [Строк] + 2
    Range("L3", Cells(Nav, 14)).Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
'

  Application.Goto Reference:="Загружен"
  Selection.PrintOut 'печать выделенного диапазона
   

' ' Шрифт чёрный
    Nav = [Строк] + 2
    Range("L3", Cells(Nav, 14)).Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
  End If
End Sub


Sub Загрузить_остатки()
 
 If Dir("C:\Ревизия\Импорт\*.*xls") = "" Then
MsgBox "нет файла"
 Exit Sub
Else
    
  Application.ScreenUpdating = False ' True
  Sheets("Инвентаризационная_ведомость").Select
  

  Columns("L:L").Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    
    Range("L2").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
'--------------------------

'' форматируем наименование, цену МХ


'---------------------
  
  Const TargDir$ = "C:\Ревизия\Импорт\", Sht& = 1
  Dim wb As Workbook, fn$
'  Application.ScreenUpdating = False
  With Workbooks.Add.Worksheets(1)
    .Cells(1) = 1: fn = Dir(TargDir & "*.xls*")
    Do While fn <> ""
      Set wb = Workbooks.Open(TargDir & fn)
      If wb.Worksheets.Count >= Sht Then _
        wb.Worksheets(Sht).UsedRange.Copy .Cells(.UsedRange.Rows.Count + 1, 1)
        wb.Close False: fn = Dir
    Loop
    
  End With
   
 
   ' УдалениеСтрокПо_Значению_в_диапазоне() ' перебор ячеек диапазона в поисках значения "da"
    Dim cell As Range, delra As Range, ТекстДляПоиска As String
    Application.ScreenUpdating = False

    ТекстДляПоиска = ""
    For Each cell In Range("F1:F30000").Cells
        If cell = ТекстДляПоиска Then
            If delra Is Nothing Then Set delra = cell Else Set delra = Union(delra, cell)
        End If
    Next
    ТекстДляПоиска1 = "Ед."
    For Each cell In Range("F1:F30000").Cells
        If cell = ТекстДляПоиска1 Then
            If delra Is Nothing Then Set delra = cell Else Set delra = Union(delra, cell)
        End If
    Next
    If Not delra Is Nothing Then delra.EntireRow.Delete
'
    Range("A" & Rows.Count).End(xlUp).Offset(0).Select  'Последняя строка +0
    ActiveCell.Offset(0, 11).Select 'Перейти на X шагов вниз и на Y вправо
    ActiveCell.FormulaR1C1 = "0"
    ActiveCell.Offset(0, 2).Select
    ActiveCell.FormulaR1C1 = "0"
    Range("L1").FormulaR1C1 = "=RC[-5]"
    Range("L1").Select
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
   


    book = ActiveWorkbook.Name
    Columns("L:L").Select
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With

    Range("L2").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With


    ActiveSheet.UsedRange.Select 'Выделяет заполненную таблицу

    Selection.Copy
    ThisWorkbook.Activate
    Sheets("Инвентаризационная_ведомость").Select
    Range("A" & Rows.Count).End(xlUp).Offset(1).Select  'Последняя строка +1
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    ' Создать_диапазон()
    ActiveWorkbook.Names.Add Name:="Загружен", RefersToR1C1:="=" & Selection.Parent.Name & "!" & Selection.Address(ReferenceStyle:=xlR1C1)
    Calculate
    


    Windows(book).Activate
    Application.CutCopyMode = False ' Очистить буфер памяти
    ActiveWindow.Close False 'закрыть без запроса на сохранение

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
'    Перемещаем файлы в другую папку
    fso.MoveFile "C:\Ревизия\Импорт\*.xls", "C:\Ревизия\Загруженные\"

    ThisWorkbook.Activate
    Sheets("Инвентаризационная_ведомость").Select

    End If


    Range("A3:M3").Copy
    Range("A4", Cells(Nav, 13)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    Nav = [Строк] + 2
    Range("N3").FormulaR1C1 = "=RC[-2]-RC[-7]"

    Range("N3").Copy
    Range("N4", Cells(Nav, 14)).Select
    ActiveSheet.Paste

    Application.CutCopyMode = False ' Очистить буфер памяти
'


    Call дубли
    Call Удалить_Пустоты

    Nav3 = [Строк] + 2
    Range("A3", Cells(Nav3, 3)).Value = Range("A3", Cells(Nav3, 3)).Value ' Весь массив заменяем значениями
    Columns("L:L").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Range("L2").Select
    ActiveSheet.Range("$A$3:$N$50000").RemoveDuplicates Columns:=3, Header:= _
        xlYes
    
    ' форматируем границы таблицы
    Cells.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

   
    Range("Загружен").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    
   ' Место хранения вправо
  Nav = [Строк] + 2
  Range("B2", Cells(Nav, 1)).Select
  With Selection
        .HorizontalAlignment = xlRight
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    ' Цена с копейками
'
    Nav = [Строк] + 2
    Range("H3", Cells(Nav, 8)).Select
    Selection.NumberFormat = "0.00"
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    ' Наименование переносить по словам
'
  Nav = [Строк] + 2
    Range("E3", Cells(Nav, 5)).Select
  With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    ' Формат вправо
'
  Nav = [Строк] + 2
    Range("C3", Cells(Nav, 3)).Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
  Nav = [Строк] + 2
    Range("G3", Cells(Nav, 14)).Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    
    Calculate
      
'    Application.Goto Reference:="Загружен"
'    Call CommandButton1_Click
    
    
    ' Удалить_диапазон()
   Application.Goto Reference:="Загружен"
   ActiveWorkbook.Names("Загружен").Delete
'    Call Valid



    ActiveSheet.DisplayPageBreaks = False ' устраняет мерцание кнопок
    Application.ScreenUpdating = True 'False ' True
''
'     End If
End Sub



Sub Очистить_Рукописку()
'


'
    Application.ScreenUpdating = False 'False ' True
    Sheets("Инвентаризационная_ведомость").Select
    
    If [Строк] < 2# Then
    Exit Sub
    End If
    Nav = [Строк] + 3
   

    Range("A3", Cells(Nav, 15)).Select
    Selection.Delete Shift:=xlUp
    Range("A3:N3").ClearContents
    Range("A3").Select
'    Call Valid
    
    Application.ScreenUpdating = True 'False ' True
    

End Sub

Sub постраничные_итоги()
    
    Application.ScreenUpdating = False 'False True
    ActiveWindow.View = xlPageBreakPreview
    Dim i&, hpb As HPageBreak, c1 As Range, c2 As Range
    Set c1 = [A3] ' >>> первая ячейка суммируемого столбца <<<
    For Each hpb In ActiveSheet.HPageBreaks
        Set c2 = Cells(hpb.Location.Row - 1, c1.Column)
        'c2.Select
        c2.EntireRow.Insert
         
        c2.Offset(-1, 2).Formula = "=""Итог по странице: Число порядковых номеров = ""&SUBTOTAL(3," & Range(c1, c2.Offset(-2, 0)).Address & ")& ""; Сумма фактического кол-ва штук = ""&SUBTOTAL(9," & Range(c1.Offset(0, 7), c2.Offset(-2, 7)).Address & ")"
        
        Set c1 = c2
    Next
    Set c1 = Cells(Rows.Count, c1.Column).End(xlUp)
    
    ActiveWindow.View = xlPageLayoutView
    ActiveWindow.View = xlNormalView
      
    ActiveWindow.SplitRow = 2
    ActiveWindow.FreezePanes = True
    
    Application.ScreenUpdating = True 'False True
    
    
End Sub