Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 26.11.2015, 15:56   #11
a18lex
Пользователь
 
Регистрация: 02.01.2015
Сообщений: 28
По умолчанию

Прошу извинить за беспокойство. Есть ли все-таки возможность сделать как описано во втором варианте?
a18lex вне форума Ответить с цитированием
Старый 30.11.2015, 14:12   #12
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

1. файлы Исходный и Конечный должны быть в одной папке
2. в файле Конечный листов должно быть не меньше чем в файле Исходный
3. выполните Sub MakeFiles
Вложения
Тип файла: rar Исходный.rar (24.3 Кб, 19 просмотров)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 15.01.2020, 10:45   #13
Bonza_2020
Новичок
Джуниор
 
Регистрация: 08.01.2020
Сообщений: 2
По умолчанию

Цитата:
Сообщение от IgorGO Посмотреть сообщение
1. файлы Исходный и Конечный должны быть в одной папке
2. в файле Конечный листов должно быть не меньше чем в файле Исходный
3. выполните Sub MakeFiles
Добрый день!
IgorGO, большое спасибо за макрос, классно работает. Подскажите пожалуйста, что добавить в этот код, чтобы в конечных файлах (см. вложение "Исходный3") сохранялись строки с 91 по 116 (Социальные льготы, Дополнительные сведения, Основание для прекращения договора)? У меня эти строки сохраняются только для первого работника.
Вложения
Тип файла: zip Исходный3.zip (91.5 Кб, 4 просмотров)
Bonza_2020 вне форума Ответить с цитированием
Старый 16.01.2020, 03:56   #14
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

посмотрел файлы, не понял вопроса
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 16.01.2020, 11:22   #15
Bonza_2020
Новичок
Джуниор
 
Регистрация: 08.01.2020
Сообщений: 2
По умолчанию

Цитата:
Сообщение от IgorGO Посмотреть сообщение
посмотрел файлы, не понял вопроса
IgorGO, ссори, я дундук. Я пытаюсь файл «Исходный» разбить по признаку (ФИО в 1 столбце), пользуясь Вашим макросом таким образом, чтобы в файлах «Конечный» сохранились верхняя «шапка» (12 верхних строк)+нижняя «шапка» (строки с 91 по 116 в файле «Конечный» или 390-414 строка в файле «Исходный»). С верхней «шапкой» я справилась. А нижняя «шапка» копируется только в первый «конечный» файл, во втором и в следующих «конечных» файлах она затирается.
Вложения
Тип файла: zip Исходный 3.zip (96.8 Кб, 5 просмотров)
Bonza_2020 вне форума Ответить с цитированием
Старый 20.01.2020, 22:00   #16
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

используйте такой макрос:
Код:
Sub SplitByTabNum()
  Dim a, rw&(), r&, c&, rg, cnt&, wb As Workbook, ws As Worksheet
  Set ws = ThisWorkbook.Worksheets(1): ws.Activate
  a = Range(Cells(1), Cells(Rows.Count, 1).End(xlUp).Offset(1))
  Set rg = Cells.Find("Вид отпуска*", , xlValues, xlWhole, Searchformat:=False)
  If rg Is Nothing Then MsgBox "Ненайдена колонка:  Вид отпуска", vbCritical, "АВАРИЯ!!!": Exit Sub
  For r = rg.Row + 2 To UBound(a) - 1
    c = c + 1: cnt = 1: ReDim Preserve rw(1 To 2, 1 To c)
    Do While a(r + cnt, 1) = a(r, 1)
      cnt = cnt + 1
    Loop
    rw(1, c) = r: rw(2, c) = r + cnt - 1: r = r + cnt
  Next
  Set rg = Cells.Find("в этот файл"): Application.ScreenUpdating = False
  If rg Is Nothing Then Set wb = Workbooks.Add Else Set wb = ThisWorkbook
  For c = 1 To UBound(rw, 2)
    ws.Copy after:=wb.Worksheets(wb.Worksheets.Count)
    With wb.Worksheets(wb.Worksheets.Count)
    .Name = a(rw(1, c), 1)
    If rw(2, c) < UBound(a) - 1 Then .Range(rw(2, c) + 1 & ":" & UBound(a) - 1).Delete
    If rw(1, c) > rw(1, 1) Then .Range(rw(1, 1) & ":" & rw(1, c) - 1).Delete
    End With
  Next
  Application.ScreenUpdating = True:  MsgBox "Заполнено листов: " & UBound(rw, 2) & " шт."
End Sub
выполните его при активном листе с данными
*если на листе будет ячейка с тестом "в этот файл" - все листы будут добавлены в текущий файл
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Разделение кода на части kilgore Общие вопросы Delphi 11 17.07.2017 14:53
Разделение файла на две части. I_am_is_captcha Visual C++ 3 26.02.2013 15:53
Разделение файла документа на части по заголовкам. getikalex Microsoft Office Word 5 08.08.2012 15:16
Разделение массива данных на части Евгений К. Microsoft Office Excel 2 03.06.2010 13:41
разделение формы на 4 части za4ot Общие вопросы Delphi 2 03.07.2008 12:12