Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: Пред. 1 2 3 След.
RSS
[ Закрыто ] Перенос строк с форматированием и формулами конечного файла
 
#31
20.02.2020 12:22:48
Цитата
Mutarix написал:
проверил ваш вариант. не помогло.
где Ваши доказательства? Как пробовали? Куда вставляли?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#32
20.02.2020 12:29:12
Код
Option ExplicitSub 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 = "Заключение договора"Dim a As Variant
With ShtS
    a = .Range(.Cells(1, 1), .Cells(last_row, [au1].Column))
End With
Dim b As Variant
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
Dim y As Long
y = 1
Dim x As Integer
For first_row = last_row To 1 Step -1
    If InStr(1, strg, a(first_row, 32)) > 0 Then 'Условие отбора строк по "статусу заявки""
        For x = 1 To UBound(b, 2)
            b(y, x) = a(y, x)
        Next
        y = y + 1
    End If
NextShtZ.Cells(last_row_other, 1).Resize(UBound(b, 1), UBound(b, 2)) = b
y = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row
With ShtZ
    .Rows(2).Copy
    .Rows(last_row_other & ":" & y).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End WithFor 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
Как-то так. Я переделал только копирование значений и форматов. В условия и код для удаления не лез.
 
 
 
#33
20.02.2020 15:35:32
Дмитрий(The_Prist) Щербаков, доказательства во вложении.

Сейчас проверю предложенный вариантМатросНаЗебре,
Изменено: Mutarix - 21.02.2020 11:28:52
 
 
 
#34
20.02.2020 17:00:52
МатросНаЗебре, Проверил ваш вариант.
Переносит данные немного не корректно. Почемуто вставляет строку с заголовком. (Файлы приложил)
 
 
 
#35
20.02.2020 17:37:38
Вместо
Код
b(y, x) = a(y, x)
Должно быть
Код
 b(y, x) = a(first_row, x)
 
 
 
#36
20.02.2020 18:03:09
Цитата
Mutarix написал:
доказательства во вложении
там только доказательства того, что Вы либо читать не хотите, что Вам пишут, либо VBA вообще не знаете и учить не хотите. Я же написал:
Цитата
Дмитрий(The_Prist) Щербаков написал:
после выполнения нужных манипуляций определить последнюю ячейку образовавшихся данных и применить
т.е. надо по сути после этой строки как минимум(когда остались только необходимые для форматирования строки):
Код
If Not rng Is Nothing Then rng.Delete Shift:=xlUp
а Вы все сделали как Вам раньше и предлагали - ДО. На что же тогда рассчитывали, если разницы до и после не видите? Мы же не знаем когда именно у Вас там все завершается. Я вот после указанной строки вставил эти строки:
Код
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
и все работает. Что не так?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#37
21.02.2020 11:27:18
МатросНаЗебре, Спасибо. сейчас работает правильно, но всётаки остаёться один скачёк экрана после завершения макроса. Это не критично, но если есть вариант как это убрать напишите.

Дмитрий(The_Prist) Щербаков, Спасибо за уточнение. Ваш вариант также работает но мне нужно форматировать только данные которые вставляем. Если есть вариант как это сделать рад буду рассмотреть.


Друзья, С точки зрения оптимизации какой вариант будет быстрее и стабильнее работать?
Изменено: Mutarix - 21.02.2020 11:58:44
 
 
 
#38
21.02.2020 11:50:26
Цитата
Mutarix написал:
остаёться од скачёк после завершения макроса
Чего остаётся?
 
 
 
#39
21.02.2020 11:59:33
Цитата
МатросНаЗебре написал:
Чего остаётся?
Скачёк экрана. но это не критично.
 
 
 
#40
21.02.2020 12:12:31
Код
Option ExplicitSub 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"
      
    Dim rSelection As Range
    Set rSelection = Selection
      
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
Dim a As Variant
With ShtS
    a = .Range(.Cells(1, 1), .Cells(last_row, [au1].Column))
End With
Dim b As Variant
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
Dim y As Long
y = 1
Dim x As Integer
For first_row = last_row To 1 Step -1
    If InStr(1, strg, a(first_row, 32)) > 0 Then 'Условие отбора строк по "статусу заявки""
        For x = 1 To UBound(b, 2)
            b(y, x) = a(first_row, x)
        Next
        y = y + 1
    End If
Next
ShtZ.Cells(last_row_other, 1).Resize(UBound(b, 1), UBound(b, 2)) = b
y = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row
With ShtZ
    .Rows(2).Copy
    .Rows(last_row_other & ":" & y).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
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 'включает групировку первого уровня "группировать"
    
    rSelection.Parent.Parent.Activate
    rSelection.Parent.Select
    rSelection.Select
    
    Application.ScreenUpdating = True 'включаем обновление экрана
    Application.Calculation = xlCalculationAutomatic 'включаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = True 'включаем отслеживание событий
      
    MsgBox "ВЫПОЛНЕНО!", vbInformation
      
End Sub
Так должно быть получше.
 
 
 
#41
21.02.2020 13:25:56
МатросНаЗебре, без изменений.

Считаю Этап 2 по присвоению формата - ВЫПОЛНЕН
Можем приступать к Этапу 3 подстановка формул
При переносе данных нужно что бы в ячейки где предусмотрены формулы добавлялись формулы во вставленных строках.

Пример файла во вложении.
Изменено: Mutarix - 22.02.2020 21:51:10
 
 
 
#42
21.02.2020 14:51:57
Код
With ShtZ
    .Rows(2).Copy
    .Rows(last_row_other & ":" & y).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    Dim rf As Range
    On Error Resume Next
        Set rf = .Rows(2).SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If Not rf Is Nothing Then
        Dim cf As Range
        For Each cf In rf
            .Columns(cf.Column).Rows(last_row_other & ":" & y).Formula = cf.Formula
        Next
    End If
End With
Дополните блок копирования переносом формул
 
 
 
#43
21.02.2020 17:03:32
МатросНаЗебре, код работает. Только формулы ссылаються на эталонную строку, тоесть формула строки 18 должна ссылаться на строку 18, сейчас ссылеться на строку 2
 
 
 
#44
25.02.2020 13:32:38
МатросНаЗебре, подскажите пожалуйста как исправить ваш код, что бы не зависимо в какую строку вставляеться формула ссылка была на эту строку.
 
 
 
#45
25.02.2020 13:45:38
Код
.Columns(cf.Column).Rows(last_row_other & ":" & y).FormulaR1C1 = cf.FormulaR1C1
Вроде так.
 
 
 
#46
25.02.2020 15:21:14
МатросНаЗебре, спасибо работает отлично. Столкнулся со следующей проблемой:
Есть столбец W в котором есть формула. При переносе работает правильно код вставляет формулу.
Но есть один момент если вместо формулы указано значение нужно оставить значение в этой ячейке.

Тоесть логика должна быть следующей:
Если в стобце W строка n = слово "дата" тогда вставляем формулу
Если в стобце W строка n = значение отличное от слова "дата" - вставляем как значение.
Код
If .Cells (N:W) = "дата"
Then
вставляем формулу
Else
вставляем как значение
End If
Изменено: Mutarix - 25.02.2020 15:22:41
 
 
 
#47
25.02.2020 15:37:02
Код
        For Each cf In rf
            Select Case cf.Column
            Case 23
                Dim u As Long
                For u = 1 To UBound(b, 1)
                    Select Case b(u, 23)
                    Case "дата"
                        .Cells(last_row_other + u - 1, 23).FormulaR1C1 = cf.FormulaR1C1
                    End Select
                Next
            Case Else
                .Columns(cf.Column).Rows(last_row_other & ":" & y).FormulaR1C1 = cf.FormulaR1C1
            End Select
        Next
Предполагается, что в W2 есть формула.
Цитата
Mutarix написал:
Есть столбец W в котором есть формула
 
 
 
#48
25.02.2020 16:50:24
МатросНаЗебре, Большое спасибо, работает правильно. 1000 строк перенесло примерно за 3 минуты. Если есть варианты как ускорить, было бы не плохо.

P]Считаю Этап 3 - перенос данных с подстановкой формул - ВЫПОЛНЕННЫМ

Можем приступать к Этапу 4 - подстановка условного форматирования
При переносе данных нужно что бы в столбцы где предусмотрено условное форматирование обновлялись правила. Сначала макрос удаляет все существующие правила на листе, после создаёт эти правила.

Правила следующие (Использовать формулу для определения форматирования):

[/P]
Скрытый текст

Изменено: Mutarix - 26.02.2020 16:12:41
 
 
 
#49
26.02.2020 13:42:18
Привет, Всем

Нашёл код реализации подобной задачи, только он выполняет сразу форматирование.
Мне нужно что бы код сначало удалял все правила условного форматирования, а затем назначал по формулам указанным в посте выше.
Код
Sub format()  
With Range("D5", Cells(Rows.Count, 4).End(xlUp)).FormatConditions. _  
Add(xlExpression, , "=$E$2>($D5+30)")  
   .Interior.Color = vbRed  
'    .StopIfTrue = False  
End With  
End Sub

Есть идеи как это сделать и встроить в общий код?
Изменено: Mutarix - 26.02.2020 16:24:48
 
 
 
#50
27.02.2020 17:37:26
Привет, Всем

Код удаляет все правила условного форматирования, затем должен создавать правила, но после запуска макроса выдаёт ошибку:
Удаляет все правила на листе и выдаёт ошибку на 2-й строке кода.

Run-time error '1004':
Method 'Range' of object'_Worksheet' failed

Подскажите пожалуйста как исправить код что бы убрать ошибку и создалось правило условного форматирования
В столбце AC2 и до последней строки (или максимум до 5000 строки)
   
Код
   ShtS.Cells.FormatConditions.Delete
        With ShtS.Range("AC2", Cells(Rows.Count, 4).End(xlUp)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(ИЛИ($T2="";$T2=""Нет данных"";$T2=""На согласовании"");СЕГОДНЯ()-ПСТР(Y2;6;10);$T2-ПСТР(Y2;6;10))<=5")
        .Interior.Color = vbGreen
        .StopIfTrue = False
        End With
Изменено: Mutarix - 27.02.2020 18:33:20
 
 
 
#51
27.02.2020 17:48:55
найдите два отличия:
Код
With ShtS.Range("AC2", Cells(Rows.Count, 4).End(xlUp))
Код
With ShtS.Range("AC2", ShtS.Cells(ShtS.Rows.Count, 4).End(xlUp))
уж сколько раз про это писалось и рассказывалось...
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#52
27.02.2020 18:07:48
Дмитрий(The_Prist) Щербаков,
Предидущая ошибка ушла. Появилась новая.
Цитата
Run-time error '5':
Invalid procedure call or argument
Насколько мне известно, что то с аргументом. Возможно формула написана не верно.
Что с этим можно сделать?
 
 
 
#53
27.02.2020 18:11:00
Откуда нам знать? Файл у Вас, ошибка тоже. На какой строке теперь - непонятно. Возможно стиль ссылок для книги установлен R1C1, а в формуле УФ используете А1.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#54
27.02.2020 18:28:27
Дмитрий(The_Prist) Щербаков,

Файлы добавил.
Изменено: Mutarix - 27.02.2020 18:28:51
 
 
 
#55
27.02.2020 19:10:59
У Вас в формуле используется текст и сравнение с пустой строкой. Почему пустая строка не обрамляется доп.кавычками? Здесь, например:
Код
$T2=""
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#56
28.02.2020 10:26:53
Дмитрий(The_Prist) Щербаков, Вы правы. Большое спасибо, работае.
Сейчас закрашивает ячейку. Как сделать, чтобы закрашивала строку?
Изменено: Mutarix - 28.02.2020 10:28:13
 
 
 
#57
28.02.2020 12:32:50
Дмитрий(The_Prist) Щербаков,

Отвечаю на свой вопрос Как сделать что бы закрашивала диапазон.
Вот что получилось:
Код
With ShtS.Range("$A$2", ShtS.Cells(ShtS.Rows.Count, 47).End(xlUp)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(($W2<>""дата"")*($W2<>"""");$W2<=СЕГОДНЯ())")
.Interior.Color = vbCyan
.StopIfTrue = False
End With
Изменено: Mutarix - 28.02.2020 12:43:23
 
 
 
#58
28.02.2020 14:44:25
Друзья, подскажите как в этом коде сделать, что бы проверка последней строки таблицы выполнялась по первому столбцу (A2), а закрашивала V2
Код
With ShtS.Range("$V$2", ShtS.Cells(ShtS.Rows.Count, 22).End(xlUp)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(И(W2=""дата"";V2<>"""");(V2>=СЕГОДНЯ())*(V2<=(СЕГОДНЯ()+10)))")
.Interior.Color = vbYellow
.StopIfTrue = False
End With
Изменено: Mutarix - 28.02.2020 14:44:31
 
 
 
#59
28.02.2020 14:46:18
Вопрос не по теме
 
 
 
#60
28.02.2020 14:54:50
vikttur, по теме.
один из пунктов темы перенос данных с условным форматирование.
 
 
 
Страницы: Пред. 1 2 3 След.
Наверх