Добрый день, я пока только начал осваивать VBA и решения к тяжелым задачам пока не даются. Может у Вас получится решить проблему, либо подтолкнуть к правильному решению. Задача следующая: Есть один отчет (База), из которого берутся данные для многих других. В примере я создал только две вкладки (Отчет №1, Отчет №2). На деле их гораздо больше. Я не стал их форму переносить, мне бы просто понять принцип на приложенном примере. Как сделать так, чтобы по условию, пусть например кодовому слову ("В работе" указан в примере) в конце строки переносилась строки по всем отчетам но не полностью и по форме уже нового отчета. По форме отчета я имею ввиду, что часть колонок будут иметь абсолютно одинаковое название, но их расположение будет отличаться от Базы, куда вбиваются все данные. Перенос строк осуществляется в самый низ отчетов.
Темы с переносом строки по кодовому слову я видел, решения рабочие, кто их предложил спасибо Вам огромное! Но они копируют полностью строку без изменений. Надеюсь на Вашу помощь и поддержку!
Добрый день, я пока только начал осваивать VBA и решения к тяжелым задачам пока не даются. Может у Вас получится решить проблему, либо подтолкнуть к правильному решению. Задача следующая: Есть один отчет (База), из которого берутся данные для многих других. В примере я создал только две вкладки (Отчет №1, Отчет №2). На деле их гораздо больше. Я не стал их форму переносить, мне бы просто понять принцип на приложенном примере. Как сделать так, чтобы по условию, пусть например кодовому слову ("В работе" указан в примере) в конце строки переносилась строки по всем отчетам но не полностью и по форме уже нового отчета. По форме отчета я имею ввиду, что часть колонок будут иметь абсолютно одинаковое название, но их расположение будет отличаться от Базы, куда вбиваются все данные. Перенос строк осуществляется в самый низ отчетов.
Темы с переносом строки по кодовому слову я видел, решения рабочие, кто их предложил спасибо Вам огромное! Но они копируют полностью строку без изменений. Надеюсь на Вашу помощь и поддержку!skreapers
skreapers, Доброго времени суток. Для приведённого примера можно использовать следуйщий код:[vba]
Код
Option Explicit
Sub КопироватьПоУсловию() Dim wsОтчёт As Worksheet Dim заголовок As String Dim colБаза As Long, colОтчёт As Long Dim ws As Worksheet Dim nextRowОтчёт As Long Dim rngDest As Range Dim i As Long, j As Long Dim tempRow As Variant Dim found As Boolean
Dim dictБаза As Object Set dictБаза = CreateObject("Scripting.Dictionary")
With Application .ScreenUpdating = False .Calculation = xlCalculationManual
With ThisWorkbook.Worksheets("База")
Dim colCount As Long colCount = .Cells(2, .Columns.Count).End(xlToLeft).Column
Dim lastRowБаза As Long lastRowБаза = .Cells(.Rows.Count, 1).End(xlUp).Row
For colБаза = 1 To colCount заголовок = Trim(.Cells(2, colБаза).Value) If Len(заголовок) > 0 Then dictБаза(заголовок) = colБаза Next
Dim arrБаза As Variant arrБаза = .Range(.Cells(3, 1), .Cells(lastRowБаза, colCount)).Value End With
Dim arrФильтрованные As Variant ReDim arrФильтрованные(1 To UBound(arrБаза), 1 To colCount)
Dim rowOut As Long rowOut = 0
For i = 1 To UBound(arrБаза) found = False
For j = 1 To colCount
If LCase(arrБаза(i, j)) = "В работу" Then found = True Exit For End If
Next j
If found Then rowOut = rowOut + 1
For j = 1 To colCount arrФильтрованные(rowOut, j) = arrБаза(i, j) Next j
End If
Next i
If rowOut = 0 Then MsgBox "Нет строк со статусом 'В работу'.", vbInformation .Calculation = xlCalculationAutomatic .ScreenUpdating = True Exit Sub End If
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "База" Then Set wsОтчёт = ws
With wsОтчёт nextRowОтчёт = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
For colОтчёт = 1 To .Cells(2, .Columns.Count).End(xlToLeft).Column заголовок = Trim(.Cells(2, colОтчёт).Value)
If dictБаза.exists(заголовок) Then colБаза = dictБаза(заголовок) Set rngDest = .Cells(nextRowОтчёт, colОтчёт).Resize(rowOut, 1) rngDest.Value = Application.Index(arrФильтрованные, Evaluate("ROW(1:" & rowOut & ")"), colБаза) End If
Next
End With
End If
Next
.Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
MsgBox "Данные со статусом 'В работу' добавлены на все листы отчётов.", vbInformation End Sub
[/vba]Удачи.
skreapers, Доброго времени суток. Для приведённого примера можно использовать следуйщий код:[vba]
Код
Option Explicit
Sub КопироватьПоУсловию() Dim wsОтчёт As Worksheet Dim заголовок As String Dim colБаза As Long, colОтчёт As Long Dim ws As Worksheet Dim nextRowОтчёт As Long Dim rngDest As Range Dim i As Long, j As Long Dim tempRow As Variant Dim found As Boolean
Dim dictБаза As Object Set dictБаза = CreateObject("Scripting.Dictionary")
With Application .ScreenUpdating = False .Calculation = xlCalculationManual
With ThisWorkbook.Worksheets("База")
Dim colCount As Long colCount = .Cells(2, .Columns.Count).End(xlToLeft).Column
Dim lastRowБаза As Long lastRowБаза = .Cells(.Rows.Count, 1).End(xlUp).Row
For colБаза = 1 To colCount заголовок = Trim(.Cells(2, colБаза).Value) If Len(заголовок) > 0 Then dictБаза(заголовок) = colБаза Next
Dim arrБаза As Variant arrБаза = .Range(.Cells(3, 1), .Cells(lastRowБаза, colCount)).Value End With
Dim arrФильтрованные As Variant ReDim arrФильтрованные(1 To UBound(arrБаза), 1 To colCount)
Dim rowOut As Long rowOut = 0
For i = 1 To UBound(arrБаза) found = False
For j = 1 To colCount
If LCase(arrБаза(i, j)) = "В работу" Then found = True Exit For End If
Next j
If found Then rowOut = rowOut + 1
For j = 1 To colCount arrФильтрованные(rowOut, j) = arrБаза(i, j) Next j
End If
Next i
If rowOut = 0 Then MsgBox "Нет строк со статусом 'В работу'.", vbInformation .Calculation = xlCalculationAutomatic .ScreenUpdating = True Exit Sub End If
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "База" Then Set wsОтчёт = ws
With wsОтчёт nextRowОтчёт = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
For colОтчёт = 1 To .Cells(2, .Columns.Count).End(xlToLeft).Column заголовок = Trim(.Cells(2, colОтчёт).Value)
If dictБаза.exists(заголовок) Then colБаза = dictБаза(заголовок) Set rngDest = .Cells(nextRowОтчёт, colОтчёт).Resize(rowOut, 1) rngDest.Value = Application.Index(arrФильтрованные, Evaluate("ROW(1:" & rowOut & ")"), colБаза) End If
Next
End With
End If
Next
.Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
MsgBox "Данные со статусом 'В работу' добавлены на все листы отчётов.", vbInformation End Sub
Доброе утро! Код работает, вы просто волшебник ^-^ Мне неудобно, но кажется мы не совсем поняли друг друга, видимо я доношу информацию так же как и пишу макросы, извиняюсь =(. Данный макрос переносит все строки по отчету, это очень удобно, когда эти отчеты формироваться будут в первый раз. Поэтому макрос очень нужный и в таком виде. Но в последующем, когда все данные по этому макросу будут перенесены, в главный отчет будут добавляться данные по строке внизу таблицы. И нужно чтобы только эта 1 добавленная строка, так же разбегалась по отчетам. В своем письме, я и обратил внимание на какое-нибудь кодовое слово, чтобы как только все данные были внесены, ввести это слово и Вжух!
Доброе утро! Код работает, вы просто волшебник ^-^ Мне неудобно, но кажется мы не совсем поняли друг друга, видимо я доношу информацию так же как и пишу макросы, извиняюсь =(. Данный макрос переносит все строки по отчету, это очень удобно, когда эти отчеты формироваться будут в первый раз. Поэтому макрос очень нужный и в таком виде. Но в последующем, когда все данные по этому макросу будут перенесены, в главный отчет будут добавляться данные по строке внизу таблицы. И нужно чтобы только эта 1 добавленная строка, так же разбегалась по отчетам. В своем письме, я и обратил внимание на какое-нибудь кодовое слово, чтобы как только все данные были внесены, ввести это слово и Вжух!skreapers
Надо конкретнее определится вам по какому признаку можем это сделать так как обновлённый код сейчас копирует данные по критерию в строке где есть слово "В работу". Может рядом с этой колонкой проставить какой нибудь ID. Так мы сможем сравнивать данные с строки листа "База" с остальными данными на листах Отчетами. Думайте, а я пока спать.
Надо конкретнее определится вам по какому признаку можем это сделать так как обновлённый код сейчас копирует данные по критерию в строке где есть слово "В работу". Может рядом с этой колонкой проставить какой нибудь ID. Так мы сможем сравнивать данные с строки листа "База" с остальными данными на листах Отчетами. Думайте, а я пока спать.MikeVol
Я сейчас его проверяю, приятного Вам сна) Пока ошибку дает, что нет слово "В работу", хотя ставлю, но я еще не успел как следует все проверить. Если это будет работать, то я напишу простенький макрос, чтобы после этого выполнялся на удаление всех значений в колонке с кодовыми словами "В работу". Чтобы в будущем не переносились они повторно
Я сейчас его проверяю, приятного Вам сна) Пока ошибку дает, что нет слово "В работу", хотя ставлю, но я еще не успел как следует все проверить. Если это будет работать, то я напишу простенький макрос, чтобы после этого выполнялся на удаление всех значений в колонке с кодовыми словами "В работу". Чтобы в будущем не переносились они повторноskreapers
Sub КопироватьПоДвойномуУсловию() Dim dictБаза As Object: Set dictБаза = CreateObject("Scripting.Dictionary") Dim ws As Worksheet Dim заголовок As String Dim i As Long, j As Long, k As Long Dim lastRowОтчёт As Long, colОтчёт As Long Dim rowsExisting As Long, rowsToCopy As Long Dim startRow As Long, colБаза As Long
With Application .ScreenUpdating = False .Calculation = xlCalculationManual
With ThisWorkbook.Worksheets("База")
Dim colCount As Long colCount = .Cells(2, .Columns.Count).End(xlToLeft).Column
Dim lastRowБаза As Long lastRowБаза = .Cells(.Rows.Count, 1).End(xlUp).row
Dim arrБаза As Variant arrБаза = .Range(.Cells(3, 1), .Cells(lastRowБаза, colCount)).Value
For j = 1 To colCount заголовок = Trim(.Cells(2, j).Value) If Len(заголовок) > 0 Then dictБаза(заголовок) = j Next j
End With
Dim arrФильтрованные() As Variant ReDim arrФильтрованные(1 To UBound(arrБаза), 1 To colCount)
Dim rowOut As Long rowOut = 0
For i = 1 To UBound(arrБаза)
For j = 1 To colCount
If LCase(Trim(CStr(arrБаза(i, j)))) = "в работу" Then rowOut = rowOut + 1
For k = 1 To colCount arrФильтрованные(rowOut, k) = arrБаза(i, k) Next k
Exit For End If
Next j
Next i
If rowOut = 0 Then MsgBox "Нет строк со статусом 'В работу'.", vbInformation GoTo Завершение End If
Dim былоДобавлено As Boolean былоДобавлено = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "База" Then lastRowОтчёт = ws.Cells(ws.Rows.Count, 1).End(xlUp).row If lastRowОтчёт < 3 Then lastRowОтчёт = 2
If rowsToCopy > 0 Then startRow = rowsExisting + 1
For colОтчёт = 1 To ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column заголовок = Trim(ws.Cells(2, colОтчёт).Value)
If dictБаза.exists(заголовок) Then colБаза = dictБаза(заголовок)
For i = 1 To rowsToCopy ws.Cells(2 + startRow + i - 1, colОтчёт).Value = arrФильтрованные(startRow + i - 1, colБаза) Next i
End If
Next colОтчёт
былоДобавлено = True End If
End If
Next ws
MsgBox IIf(былоДобавлено, "Новые строки добавлены на соответствующие листы.", "Нет новых строк для добавления. Все данные уже на местах."), vbInformation
Завершение: .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
End Sub
[/vba]
[vba]
Код
Option Explicit
Sub КопироватьПоДвойномуУсловию() Dim dictБаза As Object: Set dictБаза = CreateObject("Scripting.Dictionary") Dim ws As Worksheet Dim заголовок As String Dim i As Long, j As Long, k As Long Dim lastRowОтчёт As Long, colОтчёт As Long Dim rowsExisting As Long, rowsToCopy As Long Dim startRow As Long, colБаза As Long
With Application .ScreenUpdating = False .Calculation = xlCalculationManual
With ThisWorkbook.Worksheets("База")
Dim colCount As Long colCount = .Cells(2, .Columns.Count).End(xlToLeft).Column
Dim lastRowБаза As Long lastRowБаза = .Cells(.Rows.Count, 1).End(xlUp).row
Dim arrБаза As Variant arrБаза = .Range(.Cells(3, 1), .Cells(lastRowБаза, colCount)).Value
For j = 1 To colCount заголовок = Trim(.Cells(2, j).Value) If Len(заголовок) > 0 Then dictБаза(заголовок) = j Next j
End With
Dim arrФильтрованные() As Variant ReDim arrФильтрованные(1 To UBound(arrБаза), 1 To colCount)
Dim rowOut As Long rowOut = 0
For i = 1 To UBound(arrБаза)
For j = 1 To colCount
If LCase(Trim(CStr(arrБаза(i, j)))) = "в работу" Then rowOut = rowOut + 1
For k = 1 To colCount arrФильтрованные(rowOut, k) = arrБаза(i, k) Next k
Exit For End If
Next j
Next i
If rowOut = 0 Then MsgBox "Нет строк со статусом 'В работу'.", vbInformation GoTo Завершение End If
Dim былоДобавлено As Boolean былоДобавлено = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "База" Then lastRowОтчёт = ws.Cells(ws.Rows.Count, 1).End(xlUp).row If lastRowОтчёт < 3 Then lastRowОтчёт = 2
If rowsToCopy > 0 Then startRow = rowsExisting + 1
For colОтчёт = 1 To ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column заголовок = Trim(ws.Cells(2, colОтчёт).Value)
If dictБаза.exists(заголовок) Then colБаза = dictБаза(заголовок)
For i = 1 To rowsToCopy ws.Cells(2 + startRow + i - 1, colОтчёт).Value = arrФильтрованные(startRow + i - 1, colБаза) Next i
End If
Next colОтчёт
былоДобавлено = True End If
End If
Next ws
MsgBox IIf(былоДобавлено, "Новые строки добавлены на соответствующие листы.", "Нет новых строк для добавления. Все данные уже на местах."), vbInformation
Завершение: .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With
MikeVol, можно я Вас еще немного побеспокою? При детальном тесте выяснилось, что макрос отказывается работать, если таблица немного больше чем 1-2 строки, и в "в работу" ставится где-нибудь внизу (файл прилагаю). Если вся правая колонка будет "в работу", то все работает отлично, но оставить там так тоже не получится, потому что если заполнять данные на других листах по перенесенным данным, а потом использовать обычный фильтр, то после повторного запуска макроса он переносит всё в уже занятые строки возвращая порядок как в листе "База", что перемешивает отчеты. Может оставить одно условие по слову "в работу"? А я бы потом уже добавил макросик детский на выделения столбца для кодового слова через Range().Select и устроил бы ему полный Selection.ClearContents ^-^
MikeVol, можно я Вас еще немного побеспокою? При детальном тесте выяснилось, что макрос отказывается работать, если таблица немного больше чем 1-2 строки, и в "в работу" ставится где-нибудь внизу (файл прилагаю). Если вся правая колонка будет "в работу", то все работает отлично, но оставить там так тоже не получится, потому что если заполнять данные на других листах по перенесенным данным, а потом использовать обычный фильтр, то после повторного запуска макроса он переносит всё в уже занятые строки возвращая порядок как в листе "База", что перемешивает отчеты. Может оставить одно условие по слову "в работу"? А я бы потом уже добавил макросик детский на выделения столбца для кодового слова через Range().Select и устроил бы ему полный Selection.ClearContents ^-^skreapers
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Побежал пробовать
