Резюме
Это короткий, но умный макрос. Он разбивает и сохраняет данные на активном листе в разные файлы CSV. Вновь созданные файлы хранятся в новой папке с именем CSV output в том же месте, что и ваш файл Excel.
Макрос VBA
Sub GenerateCSV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
iCol = 2 '### Define your criteria column
strOutputFolder = "CSV output" '### Define your path of output folder
Set ws = ThisWorkbook.ActiveSheet '### Don't edit below this line
Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)
If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder
For Each strItem In rngUnique
If strItem <> "" Then
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
Workbooks.Add
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
End If
Next
ws.ShowAllData
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Сохраните его в новом модуле VBA
Понимание кода
iCol = 2
strOutputFolder = "CSV output"
Первая строка - ваш столбец критериев. A 1 будет означать столбец A, 2 для столбца B и так далее.
Во-вторых, мы определяем имя папки, в которую должны быть сохранены все наши CSV-файлы. Вы также можете установить полный путь, например, C:\some\folder . В противном случае Excel создаст папку в месте расположения файла Excel.
Set ws = ThisWorkbook.ActiveSheet
Здесь мы сохраняем нашу текущую рабочую книгу и рабочий лист в переменной. Это не обязательно делать, но так как мы имеем дело с несколькими рабочими книгами (недавно созданными), я рекомендую это
Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)
Хорошо, что эта часть? Сначала мы ищем последнюю ячейку только в столбце критериев. Это должно быть сделано до нашей фильтрации и необходимо позже. Затем мы используем известный метод расширенного фильтра, чтобы отфильтровать все дублированные значения из нашего столбца критериев. Наконец, мы сохраняем все видимые ячейки в переменной с именем rngUnique
If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder
Посмотрим, существует ли папка с именем CSV output . Если нет, создайте
For Each strItem In rngUnique
If strItem <> "" Then
[...]
End If
Next
Теперь мы начинаем перебирать все уникальные значения в нашей переменной rngUnique. Но пустые значения пропускаются
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
Важная линия. Мы используем метод автофильтра и просматриваем все строки, которые соответствуют нашему текущему уникальному значению. Старый расширенный фильтр автоматически отменяется.
Workbooks.Add
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
Эти две строки создают новую пустую книгу и копируют только видимые ячейки из нашей входной книги
strFilename = strOutputFolder & "\" & strItem
Здесь мы соединили путь CSV. Мы берем текущее уникальное значение в качестве имени файла. Расширение CSV добавляется автоматически, так как мы выбрали xlCSV качестве выходного формата.
Убедитесь, что ваши уникальные значения не содержат недопустимых символов имени файла, таких как < > | / * \ ? " или соответствующий файл CSV не будет создан
ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
Последний шаг - сохранить текущую книгу в формате CSV и принять переменную strFilename в качестве имени файла. Разделитель CSV зависит от вашего регионального ограничителя. Можно изменить формат файла, например. на вкладку CSV или Excel 2003 с разделителями
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Первая строка немного ускоряет наш макрос, так как Excel не нужно показывать каждый шаг фильтрации.
Вторая строка подавляет надоедливые приглашения File, уже существующие . Позже мы снова включим эти функции
