Макрос excel как разбить большой текстовый файл

Добрый вечер!Можете мне подсказать, как разделить файл Excel(Прайс-лист)на несколько файлов?К примеру : есть файл Excel на 1000 строк, мне нужно 4 файла Excel по 250 строк.
Я не могу просто копировать и создавать файлы- это очень долго, у меня прайсы по 600000 строк, их надо делить на много частей, и он не один.Если Вам не сложно, можете ответить?
Если я не правильно создал тему, простите.Я первый раз на этом сайте создаю тему.

Сообщение отредактировал Stepan096 — Среда, 20.11.2013, 00:23

Сообщение Добрый вечер!Можете мне подсказать, как разделить файл Excel(Прайс-лист)на несколько файлов?К примеру : есть файл Excel на 1000 строк, мне нужно 4 файла Excel по 250 строк.
Я не могу просто копировать и создавать файлы- это очень долго, у меня прайсы по 600000 строк, их надо делить на много частей, и он не один.Если Вам не сложно, можете ответить?
Если я не правильно создал тему, простите.Я первый раз на этом сайте создаю тему. Автор — Stepan096
Дата добавления — 20.11.2013 в 00:21

Разделить файл на части

Добрый день!
Подскажите, пожалуйста, как разделить файл эксель на несколько файлов по одной из колонок.
Например, есть один файл excel, содержащий большую таблицу на несколько тысяч записей.
В таблице ФИО, возраст, пол, наименование школы. Необходимо создать новые файлы с именем, соответствующим наименованию школы. И в этих фалах должны быть люди, которые относятся к этой школе.
Пример во вложении. Файл «таблица» это исходная таблица с данными. Остальные файлы — то, что должно получиться.

Вложения

Таблица.xlsx (8.4 Кб, 18 просмотров)

МАУ ДШ №1.xlsx (8.1 Кб, 5 просмотров)

МАУ ДШ №2.xlsx (8.3 Кб, 2 просмотров)

МАУ ДШ №3.xlsx (8.2 Кб, 1 просмотров)

Лучшие ответы ( 1 )
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
Ответы с готовыми решениями:

Открыть файл, разделить ячейку на 1000, сохранить файл, закрыть файл
Макрос должен запускаться, спрашивать — какой файл ему взять. Открыть его, разделить определенную.

Разделить текст на 2 части
Есть 4 текстовых окна text1 text2 text3 text4 Нужно что бы вводимые данные и текст1, текст2.

Как разделить XML файл на 2 части?
Здравствуйте уважаемые форумчане. Нужна помощь! Есть XML файл размером более 200 мб. Необходимо.

Как разделить txt файл на равные части?
У меня есть txt-файл:). Вот его нужно разделить на равные части. Например, ра 30 частей, чтобы во.

1844 / 1159 / 354
Регистрация: 11.07.2014
Сообщений: 4,102

styana, где-то так, но не проверял, если что звоните. Загружаете все ваши файлы и запускаете единственный макрос Razbivka из файла Таблица.xlsm, в который поставите этот макрос и измените расширение xlsx на xlsm

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24

Sub Razbivka() Dim LastRow As Long, Ib As Long, Ik As Long, J As Long, S As String Dim K As Integer, Sf As String Worksheets("Лист1").Select With ActiveSheet LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 'сортируем по школам .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("F2:F" & LastRow), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange Range("A1:F" & LastRow): .Header = xlYes: .MatchCase = False .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply End With End With Ib = 2: S = Range("F2"): K = 0 For J = 2 To LastRow If Cells(J, "F") <> S Or J = LastRow Then Ik = IIf(J < LastRow, J - 1, J): K = K + 1: Sf = "МАУ ДШ №" & K Range(Cells(2, 1), Cells(Ik, 6)).Copy Destination:=Workbooks(Sf).Sheets(1).Range("A2") Ib = J End If Next End Sub

Регистрация: 22.05.2016
Сообщений: 36
Burk, благодарю за помощь!
На следующей строке появляется ошибка «Subscript out of range»

Range(Cells(2, 1), Cells(Ik, 6)).Copy Destination:=Workbooks(Sf).Sheets(1).Range("A2")

1844 / 1159 / 354
Регистрация: 11.07.2014
Сообщений: 4,102
styana, ага поспешил, расширение в Sf не поставил, теперь проверил, высылаю файл для надежности
Вложения

Razbivka.rar (14.0 Кб, 11 просмотров)

1844 / 1159 / 354
Регистрация: 11.07.2014
Сообщений: 4,102
и ещё пара неточностей была
Регистрация: 22.05.2016
Сообщений: 36
Burk, благодарю за ответ!
Но ошибка сохранилась. На той же строке.
2696 / 1681 / 768
Регистрация: 23.03.2015
Сообщений: 5,313

Лучший ответ

Сообщение было отмечено styana как решение

Решение

styana,
Как вариант .
Этот код создаст то, что вы хотите в той же папке , что и главный файл

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 28 29 30 31 32 33 34 35 36

Sub MMM() Application.ScreenUpdating = False LR = Cells(Rows.Count, 1).End(xlUp).Row ARR1 = Range(Cells(2, 1), Cells(LR, 6)).Value TTL = Range("A1:F1").Value Set MD = CreateObject("Scripting.Dictionary") For Each CL In Range(Cells(2, 6), Cells(LR, 6)).Value EL = MD.Item(CL) Next ARR_SCHOOL_NAME = MD.Keys Application.DisplayAlerts = False For i = 0 To MD.Count - 1 M = 0 ReDim ARR2(LR + 1, 6) For X = 1 To UBound(ARR1) If ARR_SCHOOL_NAME(i) = ARR1(X, 6) Then For Y = 1 To 6 ARR2(M, Y - 1) = ARR1(X, Y) Next M = M + 1 End If Next With Workbooks.Add(-4167).Worksheets(1): .Name = ARR_SCHOOL_NAME(i) .[a1:F1].Resize(6) = TTL .[a2].Resize(UBound(ARR2, 1), UBound(ARR2, 2)) = ARR2 .Parent.SaveAs Filename:=ThisWorkbook.Path & "\" & ARR_SCHOOL_NAME(i) .Parent.Close True End With Next Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox ("Задача завершена") End Sub

Разбиение текстового файла (в т.ч. CSV) на несколько файлов с заданным количеством строк

Создаваемые файлы получают имена вида filename(1).txt, filename(2).txt и т.д.

Читать:

Как восстановить apple id по номеру телефона через компьютер онлайн

Если задан параметр функции DeleteSourceFile равным TRUE, — то исходный файл удаляется после разделения

Функция возвращает коллекцию, содержащую пути к сформированным файлам

В начало каждого создаваемого файла дописывается строка заголовка — первая строка из исходного файла

Пример использования функции SplitTextFile:

Sub ПримерИспользованияФункции_SplitTextFile() ИмяРазбиваемогоФайла$ = "C:\test\2011 04 17 12-32-30.csv" МаксимальноеКоличествоСтрокВфайле& = 3 Dim СписокИмёнФайлов As Collection Set СписокИмёнФайлов = SplitTextFile(ИмяРазбиваемогоФайла$, МаксимальноеКоличествоСтрокВфайле&, vbNewLine, False) For Each Файл In СписокИмёнФайлов Debug.Print "Создан файл: " & Файл Next End Sub

Результат работы примера (из окна Immediate редактора VBA)

Создан файл: C:\test\2011 04 17 12-32-30(1).csv
Создан файл: C:\test\2011 04 17 12-32-30(2).csv
Создан файл: C:\test\2011 04 17 12-32-30(3).csv

Код функции SplitTextFile:

Function SplitTextFile(ByVal filename$, ByVal MaxRowsCount&, ByVal Delimiter$, _ Optional ByVal DeleteSourceFile As Boolean = True) As Collection ' функция предназначена для разбивки текстового файла filename$ на несколько файлов ' меньшего размера - в каждом из которых будет не более MaxRowsCount& строк ' Разделение строк выполняется с использованием разделителя Delimiter$ ' Создаваемые файлы получают имена вида filename(1).txt, filename(2).txt и т.д. ' Если DeleteSourceFile = TRUE, - то исходный файл удаляется после разбивки ' Возвращает коллекцию имён созданных файлов ext$ = "." & Split(filename$, ".")(UBound(Split(filename$, "."))) Set fso = CreateObject("scripting.filesystemobject") Set ts = fso.OpenTextFile(filename, 1, True): txt = ts.ReadAll: ts.Close HeaderRow$ = Split(txt, Delimiter$, 2)(0) & Delimiter$ ' берем первую строку из файла как заголовок txt = Split(txt, Delimiter$, 2)(1) ' остаток текста - без строки заголовка ' удаляем разделители строк в конце текстовой строки (если таковые присутствуют) While txt Like "*" & Delimiter$: txt = Left(txt, Len(txt) - Len(Delimiter$)): Wend ' RowsCount = UBound(Split(txt, Delimiter$)) + 1 ' количество текстовых строк в файле FileIndex& = 1 ' индекс очередного создаваемого файла arr = Split(txt, Delimiter$): rc = 0: Set SplitTextFile = New Collection For i = LBound(arr) To UBound(arr) rc = rc + 1 NewTXT$ = NewTXT$ & arr(i) & Delimiter$ If rc >= MaxRowsCount& Or i = UBound(arr) Then ' набрали достаточно строк для записи в файл NewFilename$ = Mid(filename$, 1, Len(filename$) - Len(ext$)) & "(" & FileIndex & ")" & ext$ Set ts = fso.CreateTextFile(NewFilename$, True) ts.Write HeaderRow$ & NewTXT$: ts.Close SplitTextFile.Add NewFilename$ FileIndex& = FileIndex& + 1 rc = 0: NewTXT$ = "" End If Next i Set ts = Nothing: Set fso = Nothing If DeleteSourceFile Then Kill filename$ ' удаляем исходный файл, если DeleteSourceFile = TRUE End Function

35042 просмотра

Не удержался напишу) На ваш комментарий Дмитрию на счет больших файлов — больше всего понравилась софтина ASAP Utilities, функционал очень богатый, а для разбиения на файлы по строкам Sheets » Split the selected range into multiple worksheets..к вам забрел с тем же вопросом, пока в данной надстройке не нашел

Автоматически разбить файл excel на несколько по условию

Имеется файл с большим количеством строк, пример во вложении.
Требуется разбить файл на несколько по первому столбцу (для каждого филиала свой файлик).
С VBA сталкиваюсь впервые, подскажите, пожалуйста, с чего начать, куда копать..
Возможно у кого-то уже есть что-то либо подобное.
Буду очень благодарен за помощь!

Лучшие ответы ( 1 )
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
Ответы с готовыми решениями:

Можно ли одну сумму разбить на несколько платежей автоматически?
допустим есть кредит 10 000 тисяч можно ли разбить автоматически сумму на платеж в месяц чтоб я в.

Как разбить столбец на несколько по условию
Есть таблица в MS SQL 2000: Адрес|Параметр|Значение 1|202|30 2|202|50 1|203|100 2|203|350 .

разбить текстовый файл на несколько
Добрый вечер! Имеется файл текстовый очень большого размера. Его надо разбить на несколько.

Разбить файл на несколько #include
Простой код. Рисует зеленую точку (квадрат) на черном фоне. #include "gl/glut.h" void.

3217 / 966 / 223
Регистрация: 29.05.2010
Сообщений: 2,085

Лучший ответ

Сообщение было отмечено crok как решение

Решение

Посмотри вариант здесь Макрос для нарезки файлов по условию требует доработки
Регистрация: 15.12.2014
Сообщений: 6

toiai, все работает, спасибо большое!

сможете еще подсказать, что нужно исправить, чтобы при выполнении не запрашивало для каждого создаваемого файла «сохранить изменения для файла?», а сразу сохраняло с именем филиала (значением первого столбца, по которому и идет отбор записей)

3217 / 966 / 223
Регистрация: 29.05.2010
Сообщений: 2,085
Вставьте в код ло начала цикла строку:

Application.DisplayAlerts=False

Не забудьте в конце выполнения вернуть значение True
Регистрация: 15.12.2014
Сообщений: 6

Теперь системное окно не выскакивает, но и результат не сохраняется.
как я понимаю не отрабатывает строка сохранения:

ActiveWorkbook.SaveAs PathFile & "\" & c.Value & ".xlsx"

вероятно поэтому каждый раз и запрашивается «Сохранить изменения в книге?»
c.Value — это как раз и есть название филиала из первого столбца? когда вылезает диалог сохранения, по умолчанию название «книга №»

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

Sub Otdelenie() Dim shSrc As Worksheet, rCol1 As Range, c As Range Dim PathFile$ Dim cl As New Collection Set shSrc = ActiveSheet PathFile = ActiveWorkbook.Path Set rCol1 = shSrc.UsedRange.Columns(1) Set rCol1 = rCol1.Cells(2).Resize(rCol1.Cells.Count - 1) On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = False For Each c In rCol1.Cells cl.Add 0, CStr(c.Value) If Err Then Err.Clear Else shSrc.Copy ActiveSheet.Range(rCol1.Address).ColumnDifferences(c).EntireRow.Delete ActiveWorkbook.SaveAs PathFile & "\" & c.Value & ".xlsx" ActiveWorkbook.Close shSrc.Activate End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub