Страницы: 1 2 3 След.
RSS
[ Закрыто ] Перенос строк с форматированием и формулами конечного файла
 
Привет, Всем

Есть файл Tool - EXCHANGE.xlsm который с помощью макроса по условию после нажатия кнопки"ЗАКУПКИ==>СНАБЖЕНИЕ" переносит строки из файла База закупки в База – Снабжение.
Сейчас перенос строк выполняется как значение, что создаёт дополнительную работу.

Нужно чтобы перенос осуществлялся с конечным форматированием и формулами. То есть если мы переносим данные по направлению из База -закупки в База – Снабжение нужно что бы данные форматировались и добавлялись формулы как в конечном файле База -Снабжения.
Обратный перенос данных также должен быть с учётом форматирования и формул в Базе – закупок.

Основная проблема в том, что сейчас после переноса данных между файлами приходиться ещё тратить время на форматирование и добавление формул.
Помогите дописать макрос чтобы данные переносились с добавлением форматирования и формул


Добавляю файлы по ссылке
Изменено: Mutarix - 13.02.2020 16:52:14
 
Друзья, насколько я вижу из бурного внимания к моему вопросу. Думаю тема сложная и нужно разделить по этапам.

Этап 1 Перенос данных - этот этап реализован в файлах по ссылке
Этап 2 форматирование вставляемых данных в соответствии с форматом таблицы куда вставляем эти данные
Этап 3 подстановка формул
Этап 4 применение условного форматирования

Предлогаю сначала разобраться с вопросом "Этап 2" как переносить данные с форматирование
 
Цитата
как переносить данные с форматирование
Код
Range.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                        SkipBlanks:=False, Transpose:=False
 
Kuzmich, Спасибо за предложенній вариант. Подкажите как правильно вставить в код:
Скрытый текст
[CODE][/CODE]
Изменено: Mutarix - 17.02.2020 11:27:28
 
Скопировали диапазон Range1, затем вставляете в нужное место при помощи PasteSpecial
Код
Range1.Copy
Cells(1,1)..PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Почитайте справку про .PasteSpecial, вам ведь еще значения или формулы надо вставлять, или ширину столбцов.
 
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
Изменено: Mutarix - 18.02.2020 11:04:37
 
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 в который вставляем данные, формат источника переносить не нужно. Ваш вариант переносит формат источника.
Изменено: Mutarix - 27.02.2020 18:47:07
 
Вариант #9 переносит формат источника. С этим вариантом всё понятно.
Чем не устраивает вариант #6?
 
МатросНаЗебре, не получаеться реализовать в моём коде.
 
Алгоритм(реализовать я думаю сами вполне способны):
создаем/определяем строку в файле-приемнике, на которую можно опереться для определения нужных форматов, а далее просто:
1. Копируем из источника данные и вставляем как значения
2. Копируем шаблонную строку и вставляем через спец.вставку только форматы.
Изменено: Дмитрий(The_Prist) Щербаков - 19.02.2020 15:49:01
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Брррр. Понятно, что не получается. Непонятно, что не получается.
Из какой строки Вы хотите скопировать формат?
 
МатросНаЗебре,

Учитывая то что файл всегда будет иметь наполнение данными, за эталон берём формат строки A2: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
  
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
 
Цитата
МатросНаЗебре написал:
ShtZ.Range("A" & 2 & ":AU" & 2)
улыбнуло:) а почему не просто?
Код
ShtZ.Range("A2:AU2")
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Да получилось забавно. )
Это всё от лени энергосбережения. Не заморачиваясь с кавыками, заменил переменную на константу.
 
МатросНаЗебре, Дмитрий(The_Prist) Щербаков,

Предложенный вариант работает.

На сколько корректно копировать полностью строку A2:AU2 вместе со значениями, а затем вставлять новые значения.
Может правельней будет копировать только формат из диапазона A2:AU2?
 
Не отвечая на вопрос "насколько корректно"...
Код
ShtZ.Range("A2:AU2").Copy 
ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Кстати, если задумались об оптимизации, то можно один раз вставить формат во вставляемые строки, и потом заполнить значения. Так, вроде, будет быстрее.
И ещё как вариант, можно запомнить вставляемые строки в массив, и вставить один раз полученный массив.
 
Цитата
Mutarix написал:
На сколько корректно копировать полностью строку A2:AU2 вместе со значениями
да нормально. Все равно перезаписываются в итоге все ячейки этой строки новыми значениями(даже если они пустые)
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков, есть один нюанс.

В формулах есть ссылки на внешний источник.
При копировании строки, Excel каждый раз (для каждой копируемой строки) просит открыть этот файл (файл источника).
Переносил 20 строк при этом 20 раз нажимал отмена.

Всётаки есть разница.  
 
МатросНаЗебре, попробовал ваш вариант.
Excel начал моргать, все действия переноса данных визуализировались.
Как его заставить выполнить эти действия в фоновом режиме.

Или

как реализовать ваше предложение

"можно один раз вставить формат во вставляемые строки, и потом заполнить значения."
Изменено: Mutarix - 19.02.2020 17:59:10
 
Цитата
Mutarix написал:
Всётаки есть разница
да. Между озвучиванием всех нюансов и их умалчиванием для помогающих.
Цитата
Mutarix написал:
как реализовать ваше предложение
а Вы не можете после выполнения нужных манипуляций определить последнюю ячейку образовавшихся данных и применить к нужному диапазону спец.вставку второй строки? Вроде того:
Код
last_row= ShtZ.Cells(ShtZ.Rows.count,1).end(xlup).row
ShtZ.Range("A2:AU2").Copy
ShtZ.Range("A3:AU" & last_row).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Цитата
Mutarix написал:
Excel начал моргать
а оптимизация при помощи Application.ScreenUpdating и т.п. не применяется, надо полагать?
Изменено: Дмитрий(The_Prist) Щербаков - 19.02.2020 18:05:29
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков,

Вот рабочий код. Оптимизации сделаны но проблема остаёться.
Код
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
Ещё не пробовал ваш вариант. Напишу дополнительно что вышло.
 
Дмитрий(The_Prist) Щербаков, проверил ваш вариант. не помогло.

МатросНаЗебре, подскажите как правильно реализовать ваш вариант

Цитата
МатросНаЗебре написал:
Кстати, если задумались об оптимизации, то можно один раз вставить формат во вставляемые строки, и потом заполнить значения. Так, вроде, будет быстрее.И ещё как вариант, можно запомнить вставляемые строки в массив, и вставить один раз полученный массив.
Изменено: Mutarix - 20.02.2020 11:50:44
Страницы: 1 2 3 След.
Наверх