Страницы: 1
RSS
Как быстро из одного файла с 1000 листами пересобрать другой файл на 300 листов в определенном порядке
 
Всем привет!

Есть условный документ на 1000 листов, (приложил для примера 1 лист), в определенном порядке размещены листы. Из него нужно сделать документ на 300 листов. Приходится вручную по наименованию искать определенный лист, переносить в новый файл эксель, нумеровать и переименовывать лист и так 300 раз.

Подскажите, какие есть способы это ускорить? Готов рассмотреть абсолютно любые.
Заранее спасибо.  
 
Иван Поддубный,
а по какому принципу Вы отбираете из 1000 только 300 листов и после их сортируете?
К сожалению, исходя из первого сообщения не совсем понятно это  ;)
Изменено: evgeniygeo - 24.06.2022 07:48:41
 
Иван Поддубный, добрый день!
Вариант пользовательским интерфейсом - копируете лист "Оглавление в свою книгу",


- в зеленой ячейке вводите название книги (куда будут скопированы листы) - жмёте кнопку "загрузить список листов"
- выбираете листы для копирования
- жмете кнопку "скопировать в новую книгу"
!!! Книга со скопированными листами создается в той же папке что и текущая (с макросом)
Код
Private Sub CommandButton1_Click()
Dim arrSheets() As String, i As Long, j As Long, wb As Workbook
j = 1
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) Then
        ReDim Preserve arrSheets(1 To j): arrSheets(j) = ListBox1.List(i): j = j + 1
    End If
Next i
Debug.Print Cells(2, 7).Value
Set wb = Application.Workbooks.Add
wb.SaveAs ThisWorkbook.Path & "\" & Cells(2, 7).Value
ThisWorkbook.Activate
Application.DisplayAlerts = False
Sheets(arrSheets).Copy after:=wb.Worksheets(wb.Sheets.Count): wb.Worksheets("Лист1").Delete: wb.Close True
Application.DisplayAlerts = True
End Sub

Private Sub CommandButton2_Click()
Dim i As Worksheet, arrOfNames() As String, j As Long
j = 1
For Each i In ThisWorkbook.Worksheets
    If i.Name <> "Оглавление" Then
        ReDim Preserve arrOfNames(1 To j): arrOfNames(j) = i.Name: j = j + 1
    End If
Next i
ListBox1.List = Application.Transpose(arrOfNames)
End Sub
Сделал на примере 3- х листов.
 
Цитата
Иван Поддубный написал:
Есть условный документ на 1000 листов, (приложил для примера 1 лист)
Что Вы имеете ввиду, 1000 листов EXCEL или 1000 листов документа на одном листе EXCEL?
Цитата
Иван Поддубный написал:
Из него нужно сделать документ на 300 листов.
опять же 300 документов на одном листе или 300 листов EXCEL?
Цитата
Иван Поддубный написал:
Приходится вручную по наименованию искать определенный лист,
Как уже спрашивал evgeniygeo, принцип отбора?
Цитата
Иван Поддубный написал:
переносить в новый файл эксель, нумеровать и переименовывать лист
нумеровать в зависимости от общего количества или в зависимости от количества листов в этом файле? Переименовывать, имена какие должны быть, из чего должны состоять или есть перечень имён?
 
Цитата
написал:
Иван Поддубный,
а по какому принципу Вы отбираете из 1000 только 300 листов и после их сортируете?
К сожалению, исходя из первого сообщения не совсем понятно это  
300 листов выбираются исходя из технического задания, а именно исходя из списка должностей конкретной организации.

Цитата
написал:
Цитата
Иван Поддубный написал:
Есть условный документ на 1000 листов, (приложил для примера 1 лист)
Что Вы имеете ввиду, 1000 листов EXCEL или 1000 листов документа на одном листе EXCEL?
Цитата
Иван Поддубный написал:
Из него нужно сделать документ на 300 листов.
опять же 300 документов на одном листе или 300 листов EXCEL?
Цитата
Иван Поддубный написал:
Приходится вручную по наименованию искать определенный лист,
Как уже спрашивал evgeniygeo, принцип отбора?
Цитата
Иван Поддубный написал:
переносить в новый файл эксель, нумеровать и переименовывать лист
нумеровать в зависимости от общего количества или в зависимости от количества листов в этом файле? Переименовывать, имена какие должны быть, из чего должны состоять или есть перечень имён?
1. 1000 листов в одном документе эксель.
2. принцип отбора выше написал, по факту хаотический порядок. Каждый новый файл уникальным получается в плане порядка листов и нумерации.
3. Нумерация исходя из количества листов в новом файле. Перечень имён файлов исходит из наименования должности. 1 лист - это 1 карта должности, соответственно оператор, инженер и другими должностями называются листы.  
 
Цитата
написал:
Иван Поддубный , добрый день!
Вариант пользовательским интерфейсом - копируете лист "Оглавление в свою книгу",


- в зеленой ячейке вводите название книги (куда будут скопированы листы) - жмёте кнопку "загрузить список листов"
- выбираете листы для копирования
- жмете кнопку "скопировать в новую книгу"
!!! Книга со скопированными листами создается в той же папке что и текущая (с макросом)
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27      Private   Sub   CommandButton1_Click()    Dim   arrSheets()   As   String  , i   As   Long  , j   As   Long  , wb   As   Workbook    j = 1    For   i = 0   To   ListBox1.ListCount - 1          If   ListBox1.Selected(i)   Then              ReDim   Preserve   arrSheets(1   To   j): arrSheets(j) = ListBox1.List(i): j = j + 1          End   If    Next   i    Debug.Print Cells(2, 7).Value    Set   wb = Application.Workbooks.Add    wb.SaveAs ThisWorkbook.Path & "\" & Cells(2, 7).Value    ThisWorkbook.Activate    Application.DisplayAlerts =   False    Sheets(arrSheets).Copy after:=wb.Worksheets(wb.Sheets.Count): wb.Worksheets(  "Лист1"  ).Delete: wb.Close   True    Application.DisplayAlerts =   True    End   Sub       Private   Sub   CommandButton2_Click()    Dim   i   As   Worksheet, arrOfNames()   As   String  , j   As   Long    j = 1    For   Each   i   In   ThisWorkbook.Worksheets          If   i.Name <>   "Оглавление"   Then              ReDim   Preserve   arrOfNames(1   To   j): arrOfNames(j) = i.Name: j = j + 1          End   If    Next   i    ListBox1.List = Application.Transpose(arrOfNames)    End   Sub   
  Сделал на примере 3- х листов.
Массив большой, 1000 листов. Из них нужно найти определенные карты, карты называются по наименованию должности "Инженер", "Техник", "Врач" итд. И разместить в определенном порядке и их уже выгрузить в новую книгу. После их нужно пронумеровать в новой последовательности. Возможно ли сделать поиск+сортировку+нумерацию? Скрин также приложил для примера
Изменено: Иван Поддубный - 26.06.2022 09:27:02
 
Цитата
написал:
Возможно ли сделать поиск+сортировку+нумерацию?
уточните, по какому критерию осуществляется поиск? если список листов отбирается по техническому заданию, то совпадение точное или по части элемента списка?

Ищем совпадение в названии имени листа или на листе?Сортировка  выбранных листов до копирования или после, уже в новой книге?

Набросал код (см ниже). В ячейки столбца А вставляете список  критериев отбора (под шапку, начиная с А2). Заполняете имя книги (D2) и нажимаете кнопку.
код:
Код
Private Sub CommandButton1_Click()
Dim arrOfNames() As String, arrCriteria, lr As Long, i, j As Long, wb As Workbook, sht As Worksheet, arrWsheets()  As String, tmp
j = 1
With Worksheets("Оглавление")
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arrCriteria = .Range(Cells(2, 1), Cells(lr, 1))
End With
For Each sht In ThisWorkbook.Worksheets
    If i <> "Оглавление" Then ReDim Preserve arrWsheets(1 To j): arrWsheets(j) = sht.name: j = j + 1
Next sht
arrCriteria = ChoiceSort_(Application.Transpose(arrCriteria)): j = 1
For Each i In arrCriteria
        ReDim Preserve arrOfNames(1 To j): arrOfNames(j) = FindNameOfSheet(i, arrWsheets)
        If arrOfNames(j) <> "" Then
            j = j + 1
        Else
            j = 1
        End If
Next i
Set wb = Application.Workbooks.Add
wb.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Оглавление").Cells(2, 4).Value

Application.DisplayAlerts = False
ThisWorkbook.Sheets(arrOfNames).Copy after:=wb.Worksheets(wb.Sheets.Count): wb.Worksheets("Лист1").Delete
j = 1
For Each i In wb.Worksheets
    i.name = RegExReplace(i.name, "\d+", j)
    j = j + 1
Next i
wb.Close True
Application.DisplayAlerts = True
End Sub

Private Function FindNameOfSheet(name, arrSht)
    Dim i
    FindNameOfSheet = ""
    For Each i In arrSht
        
        If InStr(1, CStr(i), CStr(name), vbTextCompare) > 0 Then FindNameOfSheet = i: Exit Function
    Next i
End Function
Private Function ChoiceSort_(myarr)
    Dim i, j, temp, tmp
    For i = LBound(myarr) To UBound(myarr)
        temp = i
        For j = i To UBound(myarr)
            If myarr(j) < myarr(temp) Then temp = j
        Next j
        If temp <> i Then
        tmp = myarr(i)
        myarr(i) = myarr(temp)
        myarr(temp) = tmp
        End If
    Next i
    ChoiceSort_ = myarr
End Function
Private Function RegExReplace(what, pattern, replace)
    With CreateObject("VBScript.Regexp")
        .Global = False
        .MultiLine = True
        .pattern = pattern
        If .test(what) Then RegExReplace = .replace(what, replace)
    End With
End Function
Изменено: artemkau88 - 26.06.2022 13:08:10
 
Цитата
написал:
уточните, по какому критерию осуществляется поиск? если список листов отбирается по техническому заданию, то совпадение точное или по части элемента списка?Ищем совпадение в названии имени листа или на листе?Сортировка  выбранных листов до копирования или после, уже в новой книге?Набросал код (см ниже). В ячейки столбца А вставляете список  критериев отбора (под шапку, начиная с А2). Заполняете имя книги (D2) и нажимаете кнопку.
Поиск осуществляется по части элемента списка из технического задания.К примеру, нужно найти "Врач-терапевт (участковый)", соответственно ищу по слову "терапевт". Совпадение на листе, причём наименование на каждой карте располагается в ячейке R12C4 (см.скрин). Нужна сортировка до копирования. Также возможно частичное совпадение. Ищу "медицинская сестра", а помимо неё есть "медицинская сестра участковая/стерилизационной/хирурга" итд.

Попробовал расставить должности, но почему-то не в той последовательности сформировались листы, как в ячейке с A2
 
Подправил, как понял Вас.
Сортирует листы в книге (куда копируем) по имени листа.
Тестируйте.
 
Цитата
написал:
Подправил, как понял Вас.
Сортирует листы в книге (куда копируем) по имени листа.
Тестируйте.
Забил вот эти должности, предварительно вставил 100 листов в книгу. После сохранения выдало ошибку
 
Цитата
написал:
После сохранения выдало ошибку
после сохранения чего?

Можете приложить файл- пример максимально приближенный к Вашему файлу?
Можно и дальше вести переписку и ничего не добиться в итоге.
Если не можете приложить пример, то думаю, Вам стоит обратиться в платную ветку (лично моё мнение).
Изменено: artemkau88 - 26.06.2022 19:35:37
 
Иван Поддубный, я вообще не понимаю, для чего хранить информацию в формах. По моему, вы можете хранить информацию в простой таблице, а по необходимости заполнять шаблон и его уже распечатывать, отправлять кому хотите и т.п.
 
Цитата
написал:
Цитата
написал:
После сохранения выдало ошибку
после сохранения чего?

Можете приложить файл- пример максимально приближенный к Вашему файлу?
Можно и дальше вести переписку и ничего не добиться в итоге.
Если не можете приложить пример, то думаю, Вам стоит обратиться в платную ветку (лично моё мнение).
После нажатия "Копировать в новую книгу".

Приложил файл пример, максимально приближенный. Желтым выделил, по какому значению поиск происходит - по наименованию должности. Всё остальное обезличил, но оно по сути и не должно никак на поиск влиять. Оно просто есть, таблица заполнена, строки некоторые заполнены.

ps не дает больше 100 кб прикрепить файл, прикрепляю ссылку на облако:
https://disk.yandex.ru/d/a2azgXO-RnwQSA
Изменено: Иван Поддубный - 28.06.2022 05:22:13
 
Проверяйте  :)

Файл можно скачать по ссылке: https://dropmefiles.com/rOVBP

Добавил вариант с обработкой ошибок в нумерации и нумерацией: https://dropmefiles.com/bfpKl
Изменено: artemkau88 - 29.06.2022 09:08:36
 
Цитата
написал:
Проверяйте  

Файл можно скачать по ссылке:  https://dropmefiles.com/rOVBP

Добавил вариант с обработкой ошибок в нумерации и нумерацией:  https://dropmefiles.com/bfpKl
В книгу с листом оглавления перенес 600 карт, для теста выбрал должности (скрин 1-запрос), нажал скопировать в новую книгу, и произошло следующее: абсолютно все листы, в которых есть название из списка должностей копировались в новую книгу (скрин 2-ответ). По факту должно было быть 8 листов в новой книге, а скрипт сделал 289.
Мне например нужна 1 мед.сестра с порядковым номером 13, а скрипт абсолютно всех медсестёр копирует.  
 
Цитата
написал:
Мне например нужна 1 мед.сестра с порядковым номером 13, а скрипт абсолютно всех медсестёр копирует.  
Как определить, что нужна медсестра именно с этим порядковым номером?
Изменено: artemkau88 - 30.06.2022 08:59:13
 
Вместо того, чтобы прислушаться к совету из #12, вы продолжаете мусолить заведомо неверный подход.
Представьте себе, что вам понадобилось что-то поменять в вашей форме... 1000 листов - работенка для Иван Поддубный
Тем паче, что такой макрос будет не сложнее того, что вы пытаетесь сотворить сейчас.
 
RAN, согласен с Вами.
Но если знать как отбираются номера, то можно доработать то, что есть.
 
Цитата
RAN написал:
1000 листов - работенка для  Иван Поддубный
Безумству храбрых, поём мы песню!
Цитата
RAN написал:
Тем паче, что такой макрос будет не сложнее того, что вы пытаетесь сотворить сейчас
При заполнении формы можно вообще обойтись без макросов, копирование листа с формой в новую книгу записать макрорекордером. Единственное, нужно будет писать макрос для сборки всех данных назад из 1000 форм в одну таблицу  :D
Изменено: Msi2102 - 30.06.2022 09:53:36
 
Цитата
artemkau88 написал:
Но если знать как отбираются номера, то можно доработать то, что есть
Об этом никто и не спорит, просто предлагаем оптимизировать работу. К примеру поиск нужной таблицы из 1000 таблиц не самое легкое занятие, или сбор данных с нужных таблиц будет ещё веселей
 
Цитата
написал:
Цитата
написал:
Мне например нужна 1 мед.сестра с порядковым номером 13, а скрипт абсолютно всех медсестёр копирует.  
Как определить, что нужна медсестра именно с этим порядковым номером?
порядковый номер задается техническим заданием, т.е. по факту номер определяю я.

Постараюсь всем ответить, какая конкретно задача.
Есть 1000 листов в одной книге. Нужна новая книга на 353 листа, в определенной последовательности. Каждый лист - это карта должности. Должности есть похожие частично, например: медицинская сестра по физиотерапии, медицинская сестра, медицинская сестра процедурной, медицинская сестра по массажу. Из них мне не нужны все, нужна 1 конкретная - медицинская сестра по физиотерапии. Её я ищу и переношу в новую книгу с определенным порядковым номером. И вот так в ручную я делаю 353 раза. И если задается запрос "медицинская сестра", она нужна одна, конкретная и в определенном месте под конкретным порядковым номером.

Про карты. Их я не меняю никак, только порядковый номер меняется. В каждой карте есть соответственно полное наименование должности.

Если не удалось задачу донести, могу сделать запись экрана, что конкретно я делаю и какого результата хочу достичь.  
 
Если не удалось ответ донести...  :)
Заполнив не хитрую табличку, и топнув кнопку, вы получаете НУЖНОЕ количество НУЖНЫХ заполненных листов (хочь 333, хочь 555).
Код
Sub qq()
    Dim lr&, i&
    Dim sh As Worksheet
    Application.ScreenUpdating = False
    With Sheets("Главный")
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lr
            Sheets("Шаблон").Copy after:=Sheets(Sheets.Count)
            Set sh = Sheets(Sheets.Count)
            sh.Name = i - 1 & ". " & .Cells(i, 4).Value
            sh.Cells(1, 1).Value = .Cells(i, 1).Value
            sh.Cells(3, 1).Value = .Cells(i, 2).Value
            sh.Cells(6, 1).Value = .Cells(i, 3).Value
            sh.Cells(12, 4).Value = .Cells(i, 4).Value
            sh.Cells(16, 4).Value = .Cells(i, 5).Value
            sh.Cells(14, 4).Value = .Cells(i, 6).Value
        Next
    End With
    Application.ScreenUpdating = True
End Sub
Страницы: 1
Наверх