Добрый день! У меня есть книга, в ней 4 листа, 1 лист это главная остальные 3 побочные. Мне нужно что бы, если я поставил на других листах в колонке факт какое либо число и нажал на кнопку сформировать, то подтянулись значение в таблицу на главной. Ну т.е. если есть значение в стобце факт, то подтягивать строку с этими значениями в главную таблицу.
Добрый день! У меня есть книга, в ней 4 листа, 1 лист это главная остальные 3 побочные. Мне нужно что бы, если я поставил на других листах в колонке факт какое либо число и нажал на кнопку сформировать, то подтянулись значение в таблицу на главной. Ну т.е. если есть значение в стобце факт, то подтягивать строку с этими значениями в главную таблицу.Kirill94
Пока с ранее заполненным не делает ничего, если надо удалять — раскомментируйте закомментированные строки.[vba]
Код
Sub Butt()
Dim sh As Worksheet Dim rwf As Long, i As Long, s As String
On Error Resume Next ActiveSheet.ListObjects(1).Unlist rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Range(Rows(15), Rows(rwf - 1)).Delete 'rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 For Each sh In Worksheets If sh.Index > 1 Then s = sh.Name For i = 2 To sh.Cells(1, 1).End(xlDown).Row If Not IsEmpty(sh.Cells(i, 12)) Then sh.Rows(i).Copy Destination:=Rows(rwf) rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 End If Next i End If Next sh If rwf > 15 Then ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(14, 1), Cells(rwf - 1, 13)), , xlYes).Name = "Заказ"
End Sub
[/vba]
Пока с ранее заполненным не делает ничего, если надо удалять — раскомментируйте закомментированные строки.[vba]
Код
Sub Butt()
Dim sh As Worksheet Dim rwf As Long, i As Long, s As String
On Error Resume Next ActiveSheet.ListObjects(1).Unlist rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Range(Rows(15), Rows(rwf - 1)).Delete 'rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 For Each sh In Worksheets If sh.Index > 1 Then s = sh.Name For i = 2 To sh.Cells(1, 1).End(xlDown).Row If Not IsEmpty(sh.Cells(i, 12)) Then sh.Rows(i).Copy Destination:=Rows(rwf) rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 End If Next i End If Next sh If rwf > 15 Then ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(14, 1), Cells(rwf - 1, 13)), , xlYes).Name = "Заказ"
On Error Resume Next ActiveSheet.ListObjects(1).Unlist rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Range(Rows(15), Rows(rwf - 1)).Delete 'rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 For Each sh In Worksheets If sh.Index > 1 Then For i = 2 To sh.Cells(1, 1).End(xlDown).Row If Not IsEmpty(sh.Cells(i, 12)) Then sh.Rows(i).Copy Destination:=Rows(rwf) rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 End If Next i End If Next sh If rwf > 15 Then ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(14, 1), Cells(rwf - 1, 13)), , xlYes).Name = "Заказ"
End Sub
[/vba]
Пардон, наврал и контрольку забыл убрать:[vba]
Код
Sub Butt()
Dim sh As Worksheet Dim rwf As Long, i As Long
On Error Resume Next ActiveSheet.ListObjects(1).Unlist rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 'Range(Rows(15), Rows(rwf - 1)).Delete 'rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 For Each sh In Worksheets If sh.Index > 1 Then For i = 2 To sh.Cells(1, 1).End(xlDown).Row If Not IsEmpty(sh.Cells(i, 12)) Then sh.Rows(i).Copy Destination:=Rows(rwf) rwf = Cells(Rows.Count, 1).End(xlUp).Row + 1 End If Next i End If Next sh If rwf > 15 Then ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(14, 1), Cells(rwf - 1, 13)), , xlYes).Name = "Заказ"
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
