Здравствуйте!! Помогите,пожалуйста, возникла проблема, сама не могу решить: Необходимо ,чтоб данные из таблиц на разных листах, отмеченные +, автоматически дублировались в спецификации. Заранее спасибо и не перестаю извиняться за некорректность названия темы.
Здравствуйте!! Помогите,пожалуйста, возникла проблема, сама не могу решить: Необходимо ,чтоб данные из таблиц на разных листах, отмеченные +, автоматически дублировались в спецификации. Заранее спасибо и не перестаю извиняться за некорректность названия темы.Незнакомка
Макрос в лист Спецификация, предварительно очистить предыдущие данные [vba]
Код
Private Sub CommandButton1_Click() Dim Sht As Worksheet Dim i As Long Dim iLastRow As Long Dim iLR As Long Dim Spec As Worksheet Set Spec = ThisWorkbook.Worksheets("Спецификация") For Each Sht In Worksheets If Sht.Name <> "Спецификация" Then ' кроме листа With Sht iLastRow = Spec.Cells(Rows.Count, 2).End(xlUp).Row + 1 iLR = .Cells(Rows.Count, 1).End(xlUp).Row For i = 4 To iLR If .Cells(i, 6) = "+" Then .Range("A" & i & ":E" & i).Copy Spec.Cells(iLastRow, 2).PasteSpecial xlPasteValues Spec.Cells(iLastRow, 7) = Sht.Name iLastRow = Spec.Cells(Rows.Count, 2).End(xlUp).Row + 1 End If Next End With End If Next End Sub
[/vba]
Макрос в лист Спецификация, предварительно очистить предыдущие данные [vba]
Код
Private Sub CommandButton1_Click() Dim Sht As Worksheet Dim i As Long Dim iLastRow As Long Dim iLR As Long Dim Spec As Worksheet Set Spec = ThisWorkbook.Worksheets("Спецификация") For Each Sht In Worksheets If Sht.Name <> "Спецификация" Then ' кроме листа With Sht iLastRow = Spec.Cells(Rows.Count, 2).End(xlUp).Row + 1 iLR = .Cells(Rows.Count, 1).End(xlUp).Row For i = 4 To iLR If .Cells(i, 6) = "+" Then .Range("A" & i & ":E" & i).Copy Spec.Cells(iLastRow, 2).PasteSpecial xlPasteValues Spec.Cells(iLastRow, 7) = Sht.Name iLastRow = Spec.Cells(Rows.Count, 2).End(xlUp).Row + 1 End If Next End With End If Next End Sub
Kuzmich, получилось с макросом!!!! единственное когда + в таблицах убираю, значения в спецификации остаются, можно ли как-то учесть это??? спасибо.
Kuzmich, получилось с макросом!!!! единственное когда + в таблицах убираю, значения в спецификации остаются, можно ли как-то учесть это??? спасибо.Незнакомка
Здравствуйте!!! Подскажите,пожалуйста, в процессе работы, выявились недочеты работы макроса, при заполнении таблиц , менялись размеры ячеек, в связи с чем программа стала "ругаться" и выдавать ошибку, помогите ,пожалуйста устранить этот недочет...спасибо
Здравствуйте!!! Подскажите,пожалуйста, в процессе работы, выявились недочеты работы макроса, при заполнении таблиц , менялись размеры ячеек, в связи с чем программа стала "ругаться" и выдавать ошибку, помогите ,пожалуйста устранить этот недочет...спасибоНезнакомка
Незнакомка! Все листы, кроме листа Спецификация должны иметь одну структуру, у вас не так. В первоначальном варианте на листе Спецификация у вас не было внизу таблицы шапки, поэтому в макросе надо изменить код определения последней строки. И старайтесь избегать объединенных ячеек! Посмотрите файл.
Незнакомка! Все листы, кроме листа Спецификация должны иметь одну структуру, у вас не так. В первоначальном варианте на листе Спецификация у вас не было внизу таблицы шапки, поэтому в макросе надо изменить код определения последней строки. И старайтесь избегать объединенных ячеек! Посмотрите файл.Kuzmich
Сделайте ваши листы в едином формате, как ДСП и Фасады На листе Спецификация уберите объединенные ячейки (сделайте в В2 - Спецификация, в С2 - Приложение к договору №) [vba]
Код
Sub Макрос1() Dim Sht As Worksheet Dim i As Long Dim iLastRow As Long Dim iLR As Long Dim Spec As Worksheet Set Spec = ThisWorkbook.Worksheets("Спецификация") Spec.Range("B4:G43").ClearContents 'очищаем спецификацию For Each Sht In Worksheets If Sht.Name <> "Спецификация" Then ' кроме листа With Sht iLastRow = Spec.[B1].End(xlDown).Row + 1 iLR = .Cells(Rows.Count, 2).End(xlUp).Row For i = 4 To iLR If .Cells(i, 7) = "+" Then .Range("B" & i & ":F" & i).Copy Spec.Cells(iLastRow, 2).PasteSpecial xlPasteValues Spec.Cells(iLastRow, 7) = Sht.Name iLastRow = Spec.[B1].End(xlDown).Row + 1 If iLastRow = 43 Then MsgBox "Нет места в таблице для спецификаций" End If Next End With End If Next End Sub
[/vba]
Сделайте ваши листы в едином формате, как ДСП и Фасады На листе Спецификация уберите объединенные ячейки (сделайте в В2 - Спецификация, в С2 - Приложение к договору №) [vba]
Код
Sub Макрос1() Dim Sht As Worksheet Dim i As Long Dim iLastRow As Long Dim iLR As Long Dim Spec As Worksheet Set Spec = ThisWorkbook.Worksheets("Спецификация") Spec.Range("B4:G43").ClearContents 'очищаем спецификацию For Each Sht In Worksheets If Sht.Name <> "Спецификация" Then ' кроме листа With Sht iLastRow = Spec.[B1].End(xlDown).Row + 1 iLR = .Cells(Rows.Count, 2).End(xlUp).Row For i = 4 To iLR If .Cells(i, 7) = "+" Then .Range("B" & i & ":F" & i).Copy Spec.Cells(iLastRow, 2).PasteSpecial xlPasteValues Spec.Cells(iLastRow, 7) = Sht.Name iLastRow = Spec.[B1].End(xlDown).Row + 1 If iLastRow = 43 Then MsgBox "Нет места в таблице для спецификаций" End If Next End With End If Next End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
выдает значек браузера,и отказывается даже открываться
