Есть файл Tool - EXCHANGE.xlsm который с помощью макроса по условию после нажатия кнопки"ЗАКУПКИ==>СНАБЖЕНИЕ" переносит строки из файла База закупки в База – Снабжение. Сейчас перенос строк выполняется как значение, что создаёт дополнительную работу.
Нужно чтобы перенос осуществлялся с конечным форматированием и формулами. То есть если мы переносим данные по направлению из База -закупки в База – Снабжение нужно что бы данные форматировались и добавлялись формулы как в конечном файле База -Снабжения. Обратный перенос данных также должен быть с учётом форматирования и формул в Базе – закупок.
Основная проблема в том, что сейчас после переноса данных между файлами приходиться ещё тратить время на форматирование и добавление формул. Помогите дописать макрос чтобы данные переносились с добавлением форматирования и формул
Друзья, насколько я вижу из бурного внимания к моему вопросу. Думаю тема сложная и нужно разделить по этапам.
Этап 1 Перенос данных - этот этап реализован в файлах по ссылке Этап 2 форматирование вставляемых данных в соответствии с форматом таблицы куда вставляем эти данные Этап 3 подстановка формул Этап 4 применение условного форматирования
Предлогаю сначала разобраться с вопросом "Этап 2" как переносить данные с форматирование
Kuzmich, Спасибо за предложенній вариант. Подкажите как правильно вставить в код:
Скрытый текст
Код
Sub perenosSZ()
Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer
On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
For first_row = last_row To 1 Step -1
If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
Else
Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
End If
last_row_other = last_row_other + 1
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне
MsgBox "ВЫПОЛНЕНО!", vbInformation
End Sub
Kuzmich, Подскажите как правильно вставить вашу строку в мой код?
Код
Sub perenosSZ()
Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer
On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
For first_row = last_row To 1 Step -1
If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
Else
Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
End If
last_row_other = last_row_other + 1
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне
MsgBox "ВЫПОЛНЕНО!", vbInformation
End Sub
Kuzmich, , в моём коде нет копирования и вставки строк. Принцып работы моего кода это присвоения значения строки одного файла другому, то есть например: Книга1Строка (А1:AU1)=Книга2Строка(А2:AU2)
Применить придложенный вариант не получаеться, так как нет действия коприрования и вставки.
Помогите пожалуйста как приментить предложенный вариант к моему коду или предложите другой вариант переноса данных с вставкой форматирования конечного файла.
Sub perenosSZ()
Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer
Dim a As Variant
On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
For first_row = last_row To 1 Step -1
If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
ShtS.Range("A" & first_row & ":AU" & first_row).Copy ShtZ.Range("A" & last_row_other & ":AU" & last_row_other)
a = ShtS.Range("A" & first_row & ":AU" & first_row)
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other) = a
If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
Else
Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
End If
last_row_other = last_row_other + 1
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне
MsgBox "ВЫПОЛНЕНО!", vbInformation
End Sub
МатросНаЗебре, Код работает, но не так как нужно. Сейчас данные копирует вместе с форматом первого файла, а мне нужно что бы формат был файла куда втавляем данные.
Вам надо скопировать формат из одного места файла в другое? Как я понял, в самом первом варианте копирование выполнялось без вставки форматирования из источника.
МатросНаЗебре, мне нужно что бы формат строк которые мы вставляем в файл2 соответствовал формату файла2 в который вставляем данные, формат источника переносить не нужно. Ваш вариант переносит формат источника.
Алгоритм(реализовать я думаю сами вполне способны): создаем/определяем строку в файле-приемнике, на которую можно опереться для определения нужных форматов, а далее просто: 1. Копируем из источника данные и вставляем как значения 2. Копируем шаблонную строку и вставляем через спец.вставку только форматы.
Sub perenosSZ()
Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer
On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
For first_row = last_row To 1 Step -1
If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
ShtZ.Range("A" & 2 & ":AU" & 2).Copy ShtZ.Range("A" & last_row_other & ":AU" & last_row_other)
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
Else
Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
End If
last_row_other = last_row_other + 1
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне
MsgBox "ВЫПОЛНЕНО!", vbInformation
End Sub
На сколько корректно копировать полностью строку A2:AU2 вместе со значениями, а затем вставлять новые значения. Может правельней будет копировать только формат из диапазона A2:AU2?
Кстати, если задумались об оптимизации, то можно один раз вставить формат во вставляемые строки, и потом заполнить значения. Так, вроде, будет быстрее. И ещё как вариант, можно запомнить вставляемые строки в массив, и вставить один раз полученный массив.
В формулах есть ссылки на внешний источник. При копировании строки, Excel каждый раз (для каждой копируемой строки) просит открыть этот файл (файл источника). Переносил 20 строк при этом 20 раз нажимал отмена.
МатросНаЗебре, попробовал ваш вариант. Excel начал моргать, все действия переноса данных визуализировались. Как его заставить выполнить эти действия в фоновом режиме.
Или
как реализовать ваше предложение
"можно один раз вставить формат во вставляемые строки, и потом заполнить значения."
а Вы не можете после выполнения нужных манипуляций определить последнюю ячейку образовавшихся данных и применить к нужному диапазону спец.вставку второй строки? Вроде того:
Вот рабочий код. Оптимизации сделаны но проблема остаёться.
Код
Sub perenosSZ()
Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer
On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
'проверяем открыт ли файл для загрузки данных с всплывающим сообщением о необходимости выполнит действие
If ShtZ Is Nothing Then
retZ = MsgBox("ВНИМАНИЕ! Откройте файл База - ЗАКУПКИ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
Exit Sub
End If
If ShtS Is Nothing Then
retS = MsgBox("ВНИМАНИЕ! Откройте файл База - СНАБЖЕНИЕ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
Exit Sub
End If
On Error GoTo 0
'----------------------
If ShtZ.AutoFilterMode = True Then ShtZ.Cells.AutoFilter ' отключает все фильтры если они включены
If ShtS.AutoFilterMode = True Then ShtS.Cells.AutoFilter ' отключает все фильтры если они включены
ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
Application.ScreenUpdating = False 'отключаем обновление экрана
Application.Calculation = xlCalculationManual 'отключаем автоматический пересчёт формул после каждого действия с листом
Application.EnableEvents = False 'отключаем отслеживание событий
If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 'переключает отображения стиля ссылок "R1C1" --> "A1"
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
For first_row = last_row To 1 Step -1
If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
ShtZ.Range("A2:AU2").Copy
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'ShtZ.Range("A2:AU2").Copy ShtZ.Range("A" & last_row_other & ":AU" & last_row_other) 'копируем формат 2-й строки базы закупок и применяем к новым строкам
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
Else
Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
End If
last_row_other = last_row_other + 1
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне
If ShtZ.AutoFilterMode = False Then ShtZ.Cells.AutoFilter ' включает все фильтра если они отключены
If ShtS.AutoFilterMode = False Then ShtS.Cells.AutoFilter ' включает все фильтра если они отключены
ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
Application.ScreenUpdating = True 'включаем обновление экрана
Application.Calculation = xlCalculationAutomatic 'включаем автоматический пересчёт формул после каждого действия с листом
Application.EnableEvents = True 'включаем отслеживание событий
MsgBox "ВЫПОЛНЕНО!", vbInformation
End Sub
Ещё не пробовал ваш вариант. Напишу дополнительно что вышло.
МатросНаЗебре, подскажите как правильно реализовать ваш вариант
Цитата
МатросНаЗебре написал: Кстати, если задумались об оптимизации, то можно один раз вставить формат во вставляемые строки, и потом заполнить значения. Так, вроде, будет быстрее.И ещё как вариант, можно запомнить вставляемые строки в массив, и вставить один раз полученный массив.