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

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

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

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

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

Ответ
 
Опции темы Поиск в этой теме
Старый 25.11.2015, 14:26   #1
a18lex
Пользователь
 
Регистрация: 02.01.2015
Сообщений: 28
По умолчанию Разделение файла на части с помощью макроса (с условием)

Здравствуйте, уважаемые форумчане!

Прошу Вас поделиться своим интеллектуальным талантом и посодействовать мне в создании макроса с помощью которого можно было бы разбить файл на несколько штук.

Суть следующая: есть большое количество строк в файле "исходный", в столбце A -название, по которому надо разделить файлы. Необходимо, чтобы все строки с одинаковым наименованием в столбце A, попали в приложенный файл "конечный" на лист "BOM", начиная с 4 строки.
После этого необходимо, чтобы файл "конечный" "сохранился как" в текущей папке с названием текущей даты (пример: 2015 11 25) и названием из столбца A листа "BOM".
Это необходимо сделать для всех повторяющихся позиций "исходного" файла.
Очень надеюсь на Вашу помощь!
Вложения
Тип файла: xlsx Исходный.xlsx (9.7 Кб, 25 просмотров)
Тип файла: xls Конечный.xls (61.0 Кб, 24 просмотров)
a18lex вне форума Ответить с цитированием
Старый 25.11.2015, 14:37   #2
a18lex
Пользователь
 
Регистрация: 02.01.2015
Сообщений: 28
По умолчанию

Возможно я не очень ясно выразился в условии поставленной задачи, я с радостью отвечу на все уточняющие вопросы.
a18lex вне форума Ответить с цитированием
Старый 25.11.2015, 15:01   #3
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

я б сначала загнал в словарь слова из столбца А - получил список оригинальных частей.
дальше:
1) в цикле по словах из словаря : фильтр столбца А по слову из словаря с переносом резулата на отделный лист
2) в цикле по "отдельных" листах - скопировал текущий лист в новую книгу, сохранил как.
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 25.11.2015, 15:04   #4
a18lex
Пользователь
 
Регистрация: 02.01.2015
Сообщений: 28
По умолчанию

Александр, спасибо за ответ!) Хоть кто-то откликнулся. Честно сказать не представляю как сделать это на практике, может есть возможность накидать что-нибудь?
a18lex вне форума Ответить с цитированием
Старый 25.11.2015, 15:26   #5
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

ето словарь.
Код:
Sub createlibrary()
   Dim dict As dictionary
   Dim i As Long
   Set dict = New dictionary
   With dict
        For i = 4 To ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
            If Not (.Exists(CStr(Cells(i, 1)))) Then
                .Add CStr(Cells(i, 1)), Cells(i, 1).Value
            End If
        Next
   End With
End Sub
я там немного сейчас понакидываю и позже покажу
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 25.11.2015, 15:45   #6
a18lex
Пользователь
 
Регистрация: 02.01.2015
Сообщений: 28
По умолчанию

Буду весьма признателен!
Можно еще краткое пояснение по функционалу?
a18lex вне форума Ответить с цитированием
Старый 25.11.2015, 15:45   #7
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

1. файлы Исходный, Конечный должны находится в одной папке
2. Откройте файл Исходный, сделайте активным лист с данными (он там 1 и так будет активным)
3. Любым известным Вам способом выполните Sub MakeFiles

при повторном выполнение MakeFiles при совпадении имен ранее созданные файлы будут удалены без предупреждения.

Код:
Function DictRange(rg As Range)
  Dim i As Long, a As Long, s As String, k As Long, ar, d
  Set d = CreateObject("Scripting.Dictionary")
  k = 0
  For a = 1 To rg.Areas.Count
    If rg.Areas(a).Count = 1 Then ar(1, 1) = rg.Areas(a) Else ar = rg.Areas(a)
    For i = 1 To rg.Areas(a).Count
      If d.exists(ar(i, 1)) Then
        Set d(ar(i, 1)) = Application.Union(d(ar(i, 1)), rg.Areas(a).Cells(i))
      Else
        Set d(ar(i, 1)) = rg.Areas(a).Cells(i)
      End If
    Next
    k = k + rg.Areas(a).Count
  Next
  Set DictRange = d
End Function


Sub MakeFiles()
  Dim dr, k, i As Long, cDt As String, fP As String, wb As Workbook
  Const fNm As String = "Конечный.xls"
  For Each wb In Workbooks
    If wb.Name = fNm Then Exit For
  Next
  fP = ThisWorkbook.Path & Application.PathSeparator
  If wb Is Nothing Then
    If Dir(fP & fNm) = "" Then MsgBox "Не найден файл " & Chr(10) & fNm, vbCritical, "Караул!!!": End
    Set wb = Workbooks.Open(fP & fNm):  ThisWorkbook.Activate
  End If
  cDt = Format(Now, "YYYY MM DD ")
  Set dr = DictRange(Cells(4, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 3, 1)):  k = dr.keys
  For i = 0 To UBound(k)
    If Not IsEmpty(wb.Worksheets(1).Cells(4, 1)) Then _
      wb.Worksheets(1).Rows(4).Resize(wb.Worksheets(1).UsedRange.Rows.Count - 3).ClearContents
    dr(k(i)).EntireRow.Copy wb.Worksheets(1).Cells(4, 1)
    If Dir(fP & cDt & k(i)) <> "" Then Kill fP & cDt & k(i)
    wb.SaveAs fP & cDt & k(i)
  Next
  wb.Close False
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 25.11.2015, 15:49   #8
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

IgorGO, код с нуля или уже подобное задание решалось?
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 25.11.2015, 16:19   #9
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

Function DictRange - написанная мною стандартная функция с помощью которой я решаю 99.9% задач, связанных с обработкой данных организованных в таблицу

в словаре собираются диапазоны, используя смещения от диапазона с именами получаю ссылки на любую колонку с данными в таблице, используя стандартные функции листа получаю все, что можно получить с диапазона данных.
попутно данные легко копировать...

в стандартном виде Function DictRange обьемнее на несколько строк потому что связана с моим же ProgressBar.
когда данных не 20 строк как в примере, а десятки или сотни тысяч ProgressBar отвлекает пользователя от грустных мыслей, как минимум видно, что программа не зависла, а идет процесс обработки данных
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 25.11.2015, 17:05   #10
a18lex
Пользователь
 
Регистрация: 02.01.2015
Сообщений: 28
По умолчанию

IgorGO, спасибо! Чувствуется, что вы хорошо разбираетесь в своем деле.
Есть важная деталь, которую я упустил в условии - листов для заполнения несколько, как и листов с условием.

Я надеялся, что смогу сам разобраться с макросом, после того как увижу его структуру, но, признаюсь, это у меня не вышло.

Не сможете ли вы помочь мне еще раз, добавив код под это условие (файлы прилагаются). Необходимо, что бы идентичные наименования оказались в одном файле в разных вкладках.
Вложения
Тип файла: xlsx Исходный.xlsx (13.8 Кб, 17 просмотров)
Тип файла: xls Конечный.xls (67.5 Кб, 26 просмотров)
a18lex вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 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