2

Вопрос прост и может быть повторяющимся.

  1. У меня есть книга Excel, которая содержит около 50 столбцов
  2. У меня есть столбец критериев для разделения этой книги на несколько рабочих книг

Подход, как показано ниже

Name    SportGoods    quantity
ABC     CRICKETBAT    10
DEF     BaseballBat   20
GHI     football      30 
MNO     gloves        10
PQR     shoes         10 
ABCD    CRICKET SHOES 10
DEFG    BaseballBat   20
GHIL    football      30 
MNOP    gloves        10
PQRS    shoes         10 

Я ищу макрос, который позволяет мне создавать несколько книг Excel на основе столбца SportGoods, например:

  • Excel/CSV для всех предметов для крикета, таких как крикетбэт, кроссовки, перчатки
  • Excel/CSV для всех футбольных предметов, таких как футбол и обувь

В качестве входного параметра я буду указывать разные предметы для игры в крикет, разные предметы для футбола Источником будет большой лист данных Excel, который содержит ~ 5000 записей.

Может ли кто-нибудь помочь мне с макросом, который поможет в создании нескольких рабочих книг на основе вышеуказанных деталей?

1 ответ1

4

Резюме

Это короткий, но умный макрос. Он разбивает и сохраняет данные на активном листе в разные файлы 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, уже существующие . Позже мы снова включим эти функции

Всё ещё ищете ответ? Посмотрите другие вопросы с метками .