Добрый день, уважаемые форумчане! Помогите пожалуйста найти решение. Сразу скажу, я не обучалась программированию, мне нужно объяснять как школьнику )) Стоит задача: создать макрос, при выполнении которого происходит: 1. копирование определенного листа (всегда одного и того же) вместе с формулами и форматами 2. подставление в одну определенную ячейку в каждом следующем листе следующего значения (значения перечислены в таблице на другом листе). Значения не повторяются. либо так: 2. при копировании запрашивается номер ячейки, в котором записано изменяемое значение - после этого происходит копирование листа с уже новым значением.
В приложении файл. Лист который нужно копировать - Альфа, значение - регномер в ячейке В6. Очень жду ваших ответов!
Добрый день, уважаемые форумчане! Помогите пожалуйста найти решение. Сразу скажу, я не обучалась программированию, мне нужно объяснять как школьнику )) Стоит задача: создать макрос, при выполнении которого происходит: 1. копирование определенного листа (всегда одного и того же) вместе с формулами и форматами 2. подставление в одну определенную ячейку в каждом следующем листе следующего значения (значения перечислены в таблице на другом листе). Значения не повторяются. либо так: 2. при копировании запрашивается номер ячейки, в котором записано изменяемое значение - после этого происходит копирование листа с уже новым значением.
В приложении файл. Лист который нужно копировать - Альфа, значение - регномер в ячейке В6. Очень жду ваших ответов!Алсу
у меня пока получается создать копию с теми же данными, регномер приходится менять вручную. стоит цель сделать много таких листов (over 80) с изменяющимися значениями
у меня пока получается создать копию с теми же данными, регномер приходится менять вручную. стоит цель сделать много таких листов (over 80) с изменяющимися значениямиАлсу
Public Sub www() Sheets("Альфа").Copy after:=Sheets(Sheets.Count) ActiveSheet.[b6] = ActiveSheet.[b6] + 1 End Sub
[/vba]
Спасибо, но это немного не то, здесь к значению в ячейке прибавляется единица, это не порядковый номер, а регистрационный, в листе со значениями (Статистика, колонка С) они идут не по порядку (там порядок в другом). Сори, что забыла про лист со значениями подробнее написать.. так вот эти номера нужно воспринимать именно как отдельный значения) как текст. на каждом листе должен вставляться каждый следующий.. вот с этим-то у меня и проблема =/
KuklP, я не сохранила просто свой макрос, он бесполезен)
Public Sub www() Sheets("Альфа").Copy after:=Sheets(Sheets.Count) ActiveSheet.[b6] = ActiveSheet.[b6] + 1 End Sub
[/vba]
Спасибо, но это немного не то, здесь к значению в ячейке прибавляется единица, это не порядковый номер, а регистрационный, в листе со значениями (Статистика, колонка С) они идут не по порядку (там порядок в другом). Сори, что забыла про лист со значениями подробнее написать.. так вот эти номера нужно воспринимать именно как отдельный значения) как текст. на каждом листе должен вставляться каждый следующий.. вот с этим-то у меня и проблема =/Алсу
Ну, если еще чего забыла, больше переделывать не буду. [vba]
Код
Public Sub www() Dim a, i& With Sheets("Статистика") a = .Range("c4:c" & .Cells(.Rows.Count, 3).End(xlUp).Row).Value End With For i = 1 To UBound(a) If a(i, 1) <> "" Then Sheets("Альфа").Copy after:=Sheets(Sheets.Count) ActiveSheet.[b6] = CStr(a(i, 1)) End If Next End Sub
[/vba]
Ну, если еще чего забыла, больше переделывать не буду. [vba]
Код
Public Sub www() Dim a, i& With Sheets("Статистика") a = .Range("c4:c" & .Cells(.Rows.Count, 3).End(xlUp).Row).Value End With For i = 1 To UBound(a) If a(i, 1) <> "" Then Sheets("Альфа").Copy after:=Sheets(Sheets.Count) ActiveSheet.[b6] = CStr(a(i, 1)) End If Next End Sub
KuklP, попробовала, спасибо, это именно то, что нужно! Ошибку со значениями (про более 255 символов) исправила, теперь дает ошибку "метод copy из класса worksheet завершен неверно".. и не копирует до конца списка, только первые 35 штук.. Скажите, т.е. 35 это предел? хотела, чтобы все в одном файле было, но видимо придется делать несколько =/
KuklP, попробовала, спасибо, это именно то, что нужно! Ошибку со значениями (про более 255 символов) исправила, теперь дает ошибку "метод copy из класса worksheet завершен неверно".. и не копирует до конца списка, только первые 35 штук.. Скажите, т.е. 35 это предел? хотела, чтобы все в одном файле было, но видимо придется делать несколько =/Алсу
Public Sub www() Dim k As Long, wb As Workbook, wb1 As Workbook, s$ Application.DisplayAlerts = 0 Application.ScreenUpdating = 0 Set wb = ThisWorkbook s = wb.Path & "\copyof_" & wb.Name Set wb1 = Workbooks.Add(xlWorksheet) wb1.SaveAs Filename:=s, FileFormat:=xlNormal On Error Resume Next For k = 4 To wb.Sheets("Статистика").Range("c" & Rows.Count).End(xlUp).Row If wb.Sheets("Статистика").Range("c" & k) <> "" Then wb.Sheets("Альфа").Copy After:=wb1.Sheets(wb1.Sheets.Count) wb1.Sheets(wb1.Sheets.Count).Name = wb.Sheets("Статистика").Range("c" & k) End If Next k wb1.Sheets(1).Delete ReDim a(1 To wb1.Sheets.Count) For k = 1 To wb1.Sheets.Count a(k) = wb1.Sheets(k).Name Next On Error GoTo 0 wb1.Sheets(a).Copy After:=wb.Sheets(wb.Sheets.Count) wb1.Close 0 Kill s Application.ScreenUpdating = -1 Application.DisplayAlerts = -1 End Sub
[/vba]
Отрабатывает один раз. Чтоб запустить повторно, надо удалить созданные листы, сохранить книгу и перезапустить Эксель.
Без танцев с бубнами в 2003 не обошлось:
[vba]
Код
Public Sub www() Dim k As Long, wb As Workbook, wb1 As Workbook, s$ Application.DisplayAlerts = 0 Application.ScreenUpdating = 0 Set wb = ThisWorkbook s = wb.Path & "\copyof_" & wb.Name Set wb1 = Workbooks.Add(xlWorksheet) wb1.SaveAs Filename:=s, FileFormat:=xlNormal On Error Resume Next For k = 4 To wb.Sheets("Статистика").Range("c" & Rows.Count).End(xlUp).Row If wb.Sheets("Статистика").Range("c" & k) <> "" Then wb.Sheets("Альфа").Copy After:=wb1.Sheets(wb1.Sheets.Count) wb1.Sheets(wb1.Sheets.Count).Name = wb.Sheets("Статистика").Range("c" & k) End If Next k wb1.Sheets(1).Delete ReDim a(1 To wb1.Sheets.Count) For k = 1 To wb1.Sheets.Count a(k) = wb1.Sheets(k).Name Next On Error GoTo 0 wb1.Sheets(a).Copy After:=wb.Sheets(wb.Sheets.Count) wb1.Close 0 Kill s Application.ScreenUpdating = -1 Application.DisplayAlerts = -1 End Sub
[/vba]
Отрабатывает один раз. Чтоб запустить повторно, надо удалить созданные листы, сохранить книгу и перезапустить Эксель.KuklP
Public Sub www() Dim k As Long, wb As Workbook, wb1 As Workbook, s$, t$ Application.DisplayAlerts = 0 Application.ScreenUpdating = 0 Set wb = ThisWorkbook s = wb.Path & "\CopyOf_" & wb.Name Set wb1 = Workbooks.Add(xlWorksheet) wb1.SaveAs Filename:=s, FileFormat:=xlNormal On Error Resume Next For k = 4 To wb.Sheets("Статистика").Range("c" & Rows.Count).End(xlUp).Row t = CStr(wb.Sheets("Статистика").Range("c" & k)) If t <> "" Then wb.Sheets("Альфа").Copy After:=wb1.Sheets(wb1.Sheets.Count) wb1.Sheets(wb1.Sheets.Count).Name = t wb1.Sheets(wb1.Sheets.Count).[b6] = t End If Next k wb1.Sheets(1).Delete ReDim a(1 To wb1.Sheets.Count) For k = 1 To wb1.Sheets.Count a(k) = wb1.Sheets(k).Name Next On Error GoTo 0 wb1.Sheets(a).Copy After:=wb.Sheets(wb.Sheets.Count) wb1.Close 0 Kill s Application.ScreenUpdating = -1 Application.DisplayAlerts = -1 End Sub
[/vba]
Гы) Про слона-то я и забыл
[vba]
Код
Public Sub www() Dim k As Long, wb As Workbook, wb1 As Workbook, s$, t$ Application.DisplayAlerts = 0 Application.ScreenUpdating = 0 Set wb = ThisWorkbook s = wb.Path & "\CopyOf_" & wb.Name Set wb1 = Workbooks.Add(xlWorksheet) wb1.SaveAs Filename:=s, FileFormat:=xlNormal On Error Resume Next For k = 4 To wb.Sheets("Статистика").Range("c" & Rows.Count).End(xlUp).Row t = CStr(wb.Sheets("Статистика").Range("c" & k)) If t <> "" Then wb.Sheets("Альфа").Copy After:=wb1.Sheets(wb1.Sheets.Count) wb1.Sheets(wb1.Sheets.Count).Name = t wb1.Sheets(wb1.Sheets.Count).[b6] = t End If Next k wb1.Sheets(1).Delete ReDim a(1 To wb1.Sheets.Count) For k = 1 To wb1.Sheets.Count a(k) = wb1.Sheets(k).Name Next On Error GoTo 0 wb1.Sheets(a).Copy After:=wb.Sheets(wb.Sheets.Count) wb1.Close 0 Kill s Application.ScreenUpdating = -1 Application.DisplayAlerts = -1 End Sub
KuklP, теперь правильно работает, но листы не все)).. Я в принципе проблему уже решила - часть таблицы вырезала в другой файл, макрос выполнялся частями) все, что нужно было, я получила. Спасибо Вам большое за неравнодушие к проблеме)
KuklP, теперь правильно работает, но листы не все)).. Я в принципе проблему уже решила - часть таблицы вырезала в другой файл, макрос выполнялся частями) все, что нужно было, я получила. Спасибо Вам большое за неравнодушие к проблеме)Алсу
Sub www() Dim A(), Item, Sh1 As Worksheet, Sh2 As Worksheet ' With Sheets("Статистика") A = .Range("C4:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value End With Set Sh1 = Sheets("Альфа") Set Sh2 = Sh1 Application.ScreenUpdating = False For Each Item In A Item = Trim(CStr(Item)) If Item <> "" Then Set Sh2 = Worksheets.Add(, Sh2) Sh2.Name = "Рег.№ " & Item Sh1.Cells.Copy Sh2.Cells Sh2.Range("B6").Value = Item End If Next Application.ScreenUpdating = True End Sub
[/vba]
also: [vba]
Код
Sub www() Dim A(), Item, Sh1 As Worksheet, Sh2 As Worksheet ' With Sheets("Статистика") A = .Range("C4:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value End With Set Sh1 = Sheets("Альфа") Set Sh2 = Sh1 Application.ScreenUpdating = False For Each Item In A Item = Trim(CStr(Item)) If Item <> "" Then Set Sh2 = Worksheets.Add(, Sh2) Sh2.Name = "Рег.№ " & Item Sh1.Cells.Copy Sh2.Cells Sh2.Range("B6").Value = Item End If Next Application.ScreenUpdating = True End Sub
Sub www() Dim j As Long, Sh1 As Worksheet, Sh2 As Worksheet With Sheets("Статистика") Set Sh1 = Sheets("Альфа") Set Sh2 = Sh1 Application.ScreenUpdating = False For j = 4 To .Cells(.Rows.Count, "C").End(xlUp).Row If .Cells(j, 3).Value <> "" Then Set Sh2 = Worksheets.Add(, Sh2) Sh2.Name = .Cells(j, 4).Value Sh1.Cells.Copy Sh2.Cells Sh2.Range("B6").Value = .Cells(j, 3).Value End If Next Application.ScreenUpdating = True End With End Sub
[/vba]
Так, вроде, работает: [vba]
Код
Sub www() Dim j As Long, Sh1 As Worksheet, Sh2 As Worksheet With Sheets("Статистика") Set Sh1 = Sheets("Альфа") Set Sh2 = Sh1 Application.ScreenUpdating = False For j = 4 To .Cells(.Rows.Count, "C").End(xlUp).Row If .Cells(j, 3).Value <> "" Then Set Sh2 = Worksheets.Add(, Sh2) Sh2.Name = .Cells(j, 4).Value Sh1.Cells.Copy Sh2.Cells Sh2.Range("B6").Value = .Cells(j, 3).Value End If Next Application.ScreenUpdating = True End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
