| Главная » Статьи » Готовые макросы |
Нарезка файлов по уникальным значениям в таблице
| 'Нарезаем файлы по уникльным значениям в указанном диапазоне Sub НарезатьФайлы() T = Timer Application.DisplayAlerts = False Dim GeneralFilePick As FileDialog Dim Col_n As Collection 'Выбираем файл для нарезки Set GeneralFilePick = Application.FileDialog(msoFileDialogFilePicker) With GeneralFilePick ' .Filters.Add "Excel files", "*.xls*;*.xla*;*.xlsx*", 1 ' тут можно задать форматы выбираемых файлов .Title = "Выберите, пожалуйста, файл для нарезки (основной файл с данными)" .AllowMultiSelect = False ' запрещаем выбор нескольких файлов .InitialFileName = ThisWorkbook.Path .Show End With Workbooks.Open Filename:=GeneralFilePick.SelectedItems(1) 'открываем Set GeneralFile = ActiveWorkbook GeneralFileName = ActiveWorkbook.Name GeneralFilePath = ActiveWorkbook.Path GenFullName = ActiveWorkbook.FullName 'удаляем лишнее On Error Resume Next Set SelectedRange = Application.InputBox("Выберите дипазон для удаления, который не будет содержаться в нарезанных файлах. " & _ "Через CTRL+ можно несколько диапазонов выбрать. Нажмите <Отмена>, если удаления не требуются.", "Запрос данных", "", Type:=8) RangeForClearing = SelectedRange.Address RangeForClearingList = SelectedRange.Worksheet.Name GeneralFile.Sheets(RangeForClearingList).Activate If ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).ClearContents If Not ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).Clear 'ClearContents - если только значения удалить Err.Clear 'выбираем диапазон для фильтрации (нарезки) Set SelectedRange = Application.InputBox("Выберите дипазон для фильтрации (ФИО, Подразделения и т.п.), включая заголовок. <Отмена> закроет программу.", "Запрос данных", "", Type:=8) If Err <> 0 Then GeneralFile.Saved = True: GeneralFile.Close: Exit Sub filterrange = SelectedRange.Address filterrangelist = SelectedRange.Worksheet.Name HeaderCellrow = SelectedRange.Cells.Row HeaderCellColumn = SelectedRange.Cells.Column Set GeneralFolderPick = Application.FileDialog(msoFileDialogFolderPicker) With GeneralFolderPick ' .Filters.Add "Excel files", "*.xls*;*.xla*;*.xlsx*", 1 .Title = "Выберите папку для нарезки (куда складывать файлы)" .AllowMultiSelect = False .InitialFileName = ThisWorkbook.Path .Show End With GeneralFolder = GeneralFolderPick.SelectedItems(1) GenFileFormat = GeneralFile.FileFormat Application.ScreenUpdating = False 'начинаем фильтацию If GeneralFile.Sheets(filterrangelist).AutoFilterMode Then GeneralFile.Sheets(filterrangelist).Cells.AutoFilter Set Col_n = New Collection lasti = Range(filterrange).Count rangerows = HeaderCellrow + 1 & ":" & HeaderCellrow + lasti - 1 For i = 1 To lasti - 1 curfilename = Cells(HeaderCellrow + i, HeaderCellColumn) On Error Resume Next Col_n.Add curfilename, curfilename If Err = 0 Then If ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).ClearContents If Not ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).Clear If GeneralFile.Sheets(filterrangelist).AutoFilterMode Then GeneralFile.Sheets(filterrangelist).Cells.AutoFilter GeneralFile.Sheets(filterrangelist).Range(filterrange).AutoFilter field:=1, Criteria1:="<>" & curfilename GeneralFile.Sheets(filterrangelist).Rows(rangerows).SpecialCells(xlVisible).Delete GeneralFile.Sheets(filterrangelist).AutoFilterMode = False Application.CutCopyMode = False ActiveWindow.ScrollRow = 1 If ThisWorkbook.Sheets(1).Range("H6") Then GeneralFile.SaveAs Filename:=GeneralFolder & "\" & Replace_symbols(curfilename, ThisWorkbook.Sheets(1).Range("L6")) _ & ".xlsx", FileFormat:=xlOpenXMLWorkbook Else GeneralFile.SaveAs Filename:=GeneralFolder & "\" & curfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook End If GeneralFile.Close Workbooks.Open (GenFullName) Set GeneralFile = ActiveWorkbook Else Err.Clear End If Next i If ThisWorkbook.Sheets(1).Range("h2") = True Then GeneralFile.Saved = True GeneralFile.Close End If Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "Программа завершена за " & Timer - T & "сек." End Sub 'функция замены запрещенных символов для сохранения файла Function Replace_symbols(ByVal txt As String, Optional ByVal replaceTo As String) As String If replaceTo = Empty Then replaceTo = "" repTo = replaceTo St$ = "\/:*?""<>|" ‘ тут указываем символы в строку, которые необходимо заменить For i% = 1 To Len(St$) txt = Replace(txt, Mid(St$, i, 1), repTo) Next Replace_symbols = txt End Function | |
| Просмотров: 1735 | | |
| Всего комментариев: 0 | |