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
|
