Страницы: 1
RSS
Перенос строк с данными между файлами по критерию, Есть управляющий с макросом который по критерию вырезает строки в одном файле и вставляет в конец другого файла
 
Добрый день, Друзья

Пытаюсь реализовать следующую задачу:
Есть управляющий файл "Tool - ОБМЕН" в котором размещён макрос для управления данными в файлах "База Вы", "База За" и "База Сн" по заданному условию.
Условие переноса данных при нажатии кнопки в файле "Tool - ОБМЕН" следующие:
1) При нажатии кнопки "Обмен: База За --> База Сн" из файла "База За" находим и вырезаем все строки у которых в столбце 29 содержится текст (2.Договор есть в 1С, 4.Выполнено) и вставляем в файл "База Сн" в конец таблицы.

Аналогично но с другим условием:
2) При нажатии кнопки "Обмен: База За <-- База Сн" из файла "База Сн" находим и вырезаем все строки у которых в столбце 29 содержится текст (1.Заключение договора) и вставляем в файл "База За" в конец таблицы.

Аналогично но с другим условием:
3)При нажатии кнопки "Обмен: База Сн --> База Вы" из файла "База Сн" находим и вырезаем все строки у которых в столбце 29 содержится текст (4.Выполнено) и в столбце 22 не пустая ячейка и вставляем в файл "База Вы" в конец таблицы.

Скрытый текст

Так же приложил файл который реализовывает подобную задачу только между листами внутри книги.
 

а вопрос в чем?
на всякий случай

Код
Sub perenosZS()
Dim ShtF As Worksheet, strg As String
Dim ShtV As Worksheet
Set ShtF = Workbooks("База За.xlsx").Worksheets("БазаЗа")
Set ShtV = Workbooks("База Сн.xlsx").Worksheets("БазаСн")
Call per(ShtF, ShtV)
End Sub
Sub perenosSZ()
Dim ShtF As Worksheet
Dim ShtV As Worksheet
Set ShtF = Workbooks("База За.xlsx").Worksheets("БазаЗа")
Set ShtV = Workbooks("База Сн.xlsx").Worksheets("БазаСн")
Call per(ShtF, ShtV)
End Sub
Sub perenosSV()
Dim ShtF As Worksheet
Dim ShtV As Worksheet
Set ShtF = Workbooks("База За.xlsx").Worksheets("БазаЗа")
Set ShtV = Workbooks("База Сн.xlsx").Worksheets("БазаСн")
Call per(ShtF, ShtV)
End Sub
Sub per(ByRef ShtF, ByRef ShtV)
Application.ScreenUpdating = False
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
last_row = ShtF.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtV.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "2.Договор есть в 1С,4.Выполнено"
For first_row = last_row To 1 Step -1
    If InStr(1, strg, ShtF.Cells(first_row, 29).Value) > 0 Then
        ShtV.Range("A" & last_row_other & ":AR" & last_row_other).Value = ShtF.Range("A" & first_row & ":AR" & first_row).Value
        ShtF.Rows(first_row).Delete
        last_row_other = last_row_other + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

Изменено: yozhik - 05.06.2018 13:52:36
 
эмм..не совсем точно, одной переменной не хватает
исправил
Изменено: yozhik - 05.06.2018 13:12:50
 
yozhik,
Большое спасибо. Код адаптировал под свою задачу.
Ещё один вопрос как после переноса строк в каждой перенесённой строке в последней ячейке указывать текущую дату, если в этой ячейке уже записана дата не заменять на новую, а через запятую прописывать текущую.
 
Цитата
Mutarix написал:
в последней ячейке
у Вас это столбец AR, строка last_row_other
после переноса (после 33-й строки кода) сделайте проверку этой ячейки, примерно так:
Код
if ShtV.Range("AR" & last_row_other).Value ="" then ShtV.Range("AR" & last_row_other).Value=date else ShtV.Range("AR" & last_row_other).Value=ShtV.Range("AR" & last_row_other).Value & "," & date
 
yozhik, код работает отлично на маленьких файлах.
Как только размер файла увеличивается до 1000 строк время обработки достигает до 28 минут.
Код
Sub perenosZS()
Dim ShtZ As Worksheet, strg As String
Dim ShtS As Workshee
Set ShtZ = Workbooks("База За.xlsx").Worksheets("БазаЗа")
Set ShtS = Workbooks("База Сн.xlsx").Worksheets("БазаСн")
Call perZS(ShtZ, ShtS)
End Sub
Sub perZS(ByRef ShtZ, ByRef ShtS)

    Application.ScreenUpdating = False 'отключаем обновление экрана
    Application.Calculation = xlCalculationManual 'Отключаем пересчёт формул
    Application.EnableEvents = False 'отключаем отслеживание событий
    
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
last_row = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtS.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "2.Договор есть в 1С,4.Выполнено"
For first_row = last_row To 1 Step -1
    If InStr(1, strg, ShtZ.Cells(first_row, 21).Value) > 0 Then
            ShtS.Range("A" & last_row_other & ":AR" & last_row_other).Value = ShtZ.Range("A" & first_row & ":AR" & first_row).Value
        If ShtS.Range("AR" & last_row_other).Value = "" Then ShtS.Range("AR" & last_row_other).Value = "Ç->Ñ " & Date Else ShtS.Range("AR" & last_row_other).Value = ShtS.Range("AR" & last_row_other).Value & ", Ç->Ñ " & Date
            ShtZ.Rows(first_row).Delete Shift:=xlUp
            last_row_other = last_row_other + 1
    End If
Next

    Application.ScreenUpdating = True 'включаем обновление экрана
    Application.Calculation = xlCalculationAutomatic 'включаем пересчёт формул
    Application.EnableEvents = True 'включаем отслеживание событий
    
MsgBox "ВЫПОЛНЕНО!", vbInformation
    
End Sub

Как можно изменить код, что бы увеличить скорость обработки данных?
Изменено: Mutarix - 14.06.2018 09:01:31
 
Привет!
Код
    'в начало Sub perZS(ByRef ShtZ, ByRef ShtS)
    Dim rng As Range
    
    ' вместо ShtZ.Rows(first_row).Delete Shift:=xlUp вставьте
    If not rng Is Nothing Then
        Set rng = Union(rng, ShtZ.Rows(first_row))
    Else
        Set rng = ShtZ.Rows(first_row)
    End If
    'после Next вставить
    If Not rng Is Nothing Then rng.Delete Shift:=xlUp
Изменено: Inexsu - 12.06.2018 12:31:30
Сравнение прайсов, таблиц - без настроек
 
Inexsu,

Изменил код.
При выполнении пишет: invalid procedure call or argument (Неправильный вызов процедуры или аргумента)
В строке: Set rng = Union(rng, ShtZ.Rows(first_row))

Что нужно чтобы код начал работать?
Код
Sub perenosZS()
Dim ShtZ As Worksheet, strg As String
Dim ShtS As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim first_row As Integer

Dim rng As Range

Set ShtZ = Workbooks("База За.xlsx").Worksheets("БазаЗа")
Set ShtS = Workbooks("База Сн.xlsx").Worksheets("БазаСн")

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
    Application.EnableEvents = False
    
last_row = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtS.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "2.Договор есть в 1С,4.Выполнено"
For first_row = last_row To 1 Step -1
    If InStr(1, strg, ShtZ.Cells(first_row, 21).Value) > 0 Then 
            ShtS.Range("A" & last_row_other & ":AR" & last_row_other).Value = ShtZ.Range("A" & first_row & ":AR" & first_row).Value
        If ShtS.Range("AR" & last_row_other).Value = "" Then ShtS.Range("AR" & last_row_other).Value = "Ç->Ñ " & Date Else ShtS.Range("AR" & last_row_other).Value = ShtS.Range("AR" & last_row_other).Value & ", Ç->Ñ " & Date 
            If rng Is Nothing Then
                Set rng = Union(rng, ShtZ.Rows(first_row))
            Else
                Set rng = ShtZ.Rows(first_row)
            End If
            last_row_other = last_row_other + 1
    End I
Next

If Not rng Is Nothing Then rng.Delete Shift:=xlUp 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic 
    Application.EnableEvents = True 
    
MsgBox "Выполнено!", vbInformation    
End Sub
Изменено: Mutarix - 12.06.2018 11:47:55
 
Mutarix,
1. Не нужно писать через строку.
2. Код оформляйте не кнопкой спойлера, а кнопкой оформления текста в виде кода.
 
Исправил код в сообщении 7
Сравнение прайсов, таблиц - без настроек
 
Inexsu, спасибо всё работает мгновенно. Если не сложно можете объяснить принцип работы.  
 
Удалять по одной медленно.
Формирую диапазон. И удаляю.
Первый раз диапазон создаётся:
Код
Set rng = ShtZ.Rows(first_row)
Затем (если получится) дополняется:
Код
Set rng = Union(rng, ShtZ.Rows(first_row))
Сравнение прайсов, таблиц - без настроек
 
Inexsu, спасибо за пояснение.
Заметил, если в какой то из таблиц установлен фильтр, то переносятся не все данные. Когда уберешь фильтр и второй раз запускаешь макрос переносит оставшиеся строки.

Как вы думаете для этой проблемы нужно отключать фильтра?
Код
If ShtZ.AutoFilterMode = True Then ShtZ.Cells.AutoFilter ' отключает фильтр если включён
If ShtS.AutoFilterMode = True Then ShtS.Cells.AutoFilter ' отключает фильтр если включён


If ShtZ.AutoFilterMode = False Then ShtZ.Cells.AutoFilter ' включает фильтр если отключён
If ShtS.AutoFilterMode = False Then ShtS.Cells.AutoFilter ' включает фильтр если отключён
Изменено: Mutarix - 14.06.2018 10:03:48
 
Цитата
Mutarix написал:
отключать фильтра
Попробуйте:
Код
If ShtZ.AutoFilterMode Then ShtS.ShowAllData
Сравнение прайсов, таблиц - без настроек
 
Всем спасибо. Итоговый код представлен ниже. Отдельное спасибо: Inexsu и yozhik

Принцип работы кода:

1) Код находиться в отдельном файле Excel  и управляет двумя другими файлами. Это сделано для того что бы была возможность настроить общий доступ к файлам База З и База С
2) После нажатия кнопки вырезает строки по определённому критерию из файла БазаЗ и вставляет в файл БазаС
3) Дописывает текущую дату переноса в столбец AR для каждой перенесённой строки.
Скрытый текст
Изменено: Mutarix - 14.06.2018 08:59:24
Страницы: 1
Наверх