Есть очень большая таблица из меньших на листе 1 надо ее разобрать отдельно по листам. Тоесть вырезаем от слова гвозди до слова сумма строка сумма не обязательна вставляем ее на лист 2 и так далее пока таблица не будет разобрана.
Есть очень большая таблица из меньших на листе 1 надо ее разобрать отдельно по листам. Тоесть вырезаем от слова гвозди до слова сумма строка сумма не обязательна вставляем ее на лист 2 и так далее пока таблица не будет разобрана.llluckyman
Sub a() Dim LastRow As Integer, i As Integer, k As Integer LastRow = Cells(Rows.Count, 1).End(xlUp).Row k = 1 For i = 1 To LastRow If Sheets(1).Cells(i, 1) = "сумма" Then Sheets.Add After:=Sheets(Sheets.Count) With Sheets(Sheets.Count) .Range("a1:" & "h" & i - k).Value = Sheets(1).Range("a" & k & ":h" & i).Value .Range("a" & i - k + 1 & ":" & "h" & ((i - k + 1) * 2) - 2).Value = _ Sheets(1).Range("j" & k + 2 & ":q" & i + 1).Value End With k = i + 1 End If Next End Sub
[/vba]
Наверное так: [vba]
Код
Sub a() Dim LastRow As Integer, i As Integer, k As Integer LastRow = Cells(Rows.Count, 1).End(xlUp).Row k = 1 For i = 1 To LastRow If Sheets(1).Cells(i, 1) = "сумма" Then Sheets.Add After:=Sheets(Sheets.Count) With Sheets(Sheets.Count) .Range("a1:" & "h" & i - k).Value = Sheets(1).Range("a" & k & ":h" & i).Value .Range("a" & i - k + 1 & ":" & "h" & ((i - k + 1) * 2) - 2).Value = _ Sheets(1).Range("j" & k + 2 & ":q" & i + 1).Value End With k = i + 1 End If Next End Sub
Sub a() Dim LastRow As Integer, i As Integer, k As Integer, last As Integer LastRow = Cells(Rows.Count, 1).End(xlUp).Row: k = 1 For i = 1 To LastRow If LCase(Sheets(1).Cells(i, 1).Value) Like "*сумма*" Then Sheets.Add After:=Sheets(Sheets.Count) With Sheets(Sheets.Count) .Range("a5:" & "h" & i - k + 4).Value = Sheets(1).Range("a" & k & ":h" & i).Value .Range("a" & i - k + 5 & ":" & "h" & ((i - k + 1) * 2) + 2).Value = _ Sheets(1).Range("j" & k + 2 & ":q" & i + 1).Value last = .Cells(Rows.Count, 1).End(xlUp).Row With .Range("a5:h" & last) .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideHorizontal).LineStyle = xlContinuous End With .Columns("C:C").ColumnWidth = 30 .Range("D:E").EntireColumn.Delete .Range("a5:f5").MergeCells = True .Range("a1").Value = "Накладная" .Range("a" & last + 2).Value = "Роспись в получении" End With k = i + 1 End If Next End Sub
[/vba]
Код макроса с учетом последних пожеланий:
[vba]
Код
Sub a() Dim LastRow As Integer, i As Integer, k As Integer, last As Integer LastRow = Cells(Rows.Count, 1).End(xlUp).Row: k = 1 For i = 1 To LastRow If LCase(Sheets(1).Cells(i, 1).Value) Like "*сумма*" Then Sheets.Add After:=Sheets(Sheets.Count) With Sheets(Sheets.Count) .Range("a5:" & "h" & i - k + 4).Value = Sheets(1).Range("a" & k & ":h" & i).Value .Range("a" & i - k + 5 & ":" & "h" & ((i - k + 1) * 2) + 2).Value = _ Sheets(1).Range("j" & k + 2 & ":q" & i + 1).Value last = .Cells(Rows.Count, 1).End(xlUp).Row With .Range("a5:h" & last) .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideHorizontal).LineStyle = xlContinuous End With .Columns("C:C").ColumnWidth = 30 .Range("D:E").EntireColumn.Delete .Range("a5:f5").MergeCells = True .Range("a1").Value = "Накладная" .Range("a" & last + 2).Value = "Роспись в получении" End With k = i + 1 End If Next End Sub
Но есть некоторые вопросы )) Вопрос следующий можно ли как то связать гвозди 345 это исходник мне надо к нему приставит сотка и так далее и вопрос по выравниванию, шрифту и размеру в таблице . в примере указано. Очень вам признателен заранее !!!
Но есть некоторые вопросы )) Вопрос следующий можно ли как то связать гвозди 345 это исходник мне надо к нему приставит сотка и так далее и вопрос по выравниванию, шрифту и размеру в таблице . в примере указано. Очень вам признателен заранее !!!llluckyman
Jhonson, что то поломался у меня макрос .. нагенерировал листы.. вроде нормально, удалил листы, что нагенерировал, ...нажал второй раз и не работает больше
Jhonson, что то поломался у меня макрос .. нагенерировал листы.. вроде нормально, удалил листы, что нагенерировал, ...нажал второй раз и не работает больше Матраскин
Снова появились некоторые вопросы. 1) В столбце с таким значением "12:08:35" делает такую штуку "0,59452546296296" 2) по поводу центровки центрует только заголовок а не значения ниже.
Снова появились некоторые вопросы. 1) В столбце с таким значением "12:08:35" делает такую штуку "0,59452546296296" 2) по поводу центровки центрует только заголовок а не значения ниже.llluckyman
Извините за назойливость ))) А можно ли сохранить не в этом листе таблицы, а чтоб сохранялись отдельно на каждом листе, и лист был назван по названию таблицы ?
Извините за назойливость ))) А можно ли сохранить не в этом листе таблицы, а чтоб сохранялись отдельно на каждом листе, и лист был назван по названию таблицы ?llluckyman
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
