Прошу помощи у опытных программистов. Есть база клиентов на 48 городов. Необходимо написать макрос, который создаст 48 файлов, наименование каждого файла соответствует названию города и в каждый файл внесет клиентов этого города
Код
Sub SaveFile() 'Объявление переменных
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
Dim i As Integer
i = 1
Do While i <= 48
'Задаём каталог сохранения файла (в данном случае текущий каталог)
Path = ThisWorkbook.Path & "\" 'Получаем значение ячейки. На листе2 расположен список городов.
CellValue = Worksheets("Лист2").Cells(i, 1) 'Формируем итоговый путь и название файла
FinalFileName = Path & CellValue
ActiveSheet.Range("$A$2:$T$15717").AutoFilter Field:=3, Criteria1:=CellValue
'Сохраняем файл
ActiveWorkbook.SaveAs Filename:=FinalFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
i = i + 1
Loop
End Sub
Реализовал таким образом, но есть один минус - в итоге я получаю общий файл, отфильтрованный по наименованию города.
А необходимо, чтобы в нем не было лишней информации. Подскажите, как можно реализовать это, чтобы макрос работал достаточно быстро?
mrgreeen написал: чтобы макрос работал достаточно быстро
Можно использовать весь отбор в массивах с помощью словарей, а итог выкладывать на лист нового файла и сохранять этот файл. Логика такова. Забираете все данные в массив, далее берете критерий (ключ) и пробегаете по массиву занося ключи в словарь и суммируя в словаре значения ключей, что бы в дальнейшем определить размерность массива который будет в итоге переносится на лист. На форуме уже есть темы с такими условиями, просто нужно поискать.
"Все гениальное просто, а все простое гениально!!!"
mrgreeen написал: Файл прикрепить не могу, объем не позволяет
А оригинальный и не нужен, вырезка из правил гласит - Приложите файл(ы) с примером (общим весом не более 300Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
"Все гениальное просто, а все простое гениально!!!"
Sub Нарезать()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim dicOpenWb As Object: Set dicOpenWb = CreateObject("Scripting.Dictionary")
RememberWBs dicOpenWb
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
y = .Cells(.Rows.Count, 3).End(xlUp).Row
Dim a As Variant
a = .Range(.Cells(1, 3), .Cells(y, 3))
End With
Dim gorod As String
Dim wb As Workbook
Dim r As Range
For y = 1 To UBound(a, 1)
gorod = a(y, 1)
Set wb = GetWB(gorod, sh)
With wb.Sheets(1)
Set r = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
End With
sh.Rows(y).Copy r
Next
CloseWBs dicOpenWb
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Function GetWB(gorod As String, shParent As Worksheet) As Workbook
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(gorod & ".xlsm")
If wb Is Nothing Then
Set wb = Workbooks.Add
Dim s As String
s = ThisWorkbook.Path & "\" & gorod & ".xlsm"
Kill s
wb.SaveAs s, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Dim i As Integer
Application.DisplayAlerts = False
For i = wb.Worksheets.Count To 2 Step -1
wb.Worksheets(i).Delete
Next
Application.DisplayAlerts = True
shParent.Rows(1).Copy
wb.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
On Error GoTo 0
Set GetWB = wb
End Function
Private Sub RememberWBs(dic As Object)
Dim wb As Workbook
For Each wb In Application.Workbooks
dic(wb.Name) = 0
Next
End Sub
Private Sub CloseWBs(dic As Object)
Dim wb As Workbook
For Each wb In Application.Workbooks
If dic.exists(wb.Name) Then
Else
wb.Close True
End If
Next
End Sub