Имеется файл с отчетом продажам менеджеров. Одна строка - одна продажа. необходимо провести сортировку по менеджерам и разнести все данные по разным файлам. Один менеджер - один файл То есть если взять Исходную таблицу, сделать фильтр по менеджерам, скопировать все данные и вставить их в новую таблицу. Только, что бы это делалось автоматом и обновлялось при дополнении данными в исходном файле
Иван, здравствуйте Разделение таблицы по разным листам — это инструмент из надстройки автора сайта, но по этому запросу можно найти кучу других готовых решений
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Option Explicit
Const MAN_COLUMN = 8
Dim rnMain As Range
Dim arrMain As Variant
Dim arrOneMan As Variant
Sub MakeManagersFiles()
Range("A2:H271").Select
Set rnMain = Selection
JobMainRange
End Sub
Private Sub JobMainRange()
If rnMain.Columns.Count < 8 Then Exit Sub
arrMain = rnMain
Dim dicMan As Object
Set dicMan = GetDicMan(arrMain)
Dim man As Variant
For Each man In dicMan.Keys
FillArrOneMan man
JobNewWb man
Next
End Sub
Private Sub JobNewWb(ByVal man As String)
Application.StatusBar = man
Dim wb As Workbook
Set wb = Workbooks.Add(1)
With wb.Sheets(1).Cells(1, 1).Resize(UBound(arrOneMan, 1), UBound(arrOneMan, 2))
.NumberFormat = "@"
.Value = arrOneMan
.NumberFormat = "General"
Dim x As Integer
For x = 1 To .Columns.Count
.Columns(x).ColumnWidth = rnMain.Columns(x).ColumnWidth
Next
End With
Dim sFull As String
sFull = ThisWorkbook.Path & "\" & man & ".xlsx"
On Error Resume Next
Workbooks(man & ".xlsx").Close False
Kill sFull
Err.Clear
wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If Err = 0 Then
wb.Close False
Else
wb.Saved = True
End If
On Error GoTo 0
Application.StatusBar = False
End Sub
Private Sub FillArrOneMan(ByVal man As String)
ReDim arrOneMan(1 To UBound(arrMain, 1), 1 To UBound(arrMain, 2))
FillRow 1, 1
Dim y As Long
Dim u As Long
u = 1
For y = 2 To UBound(arrMain, 1)
If arrMain(y, MAN_COLUMN) = man Then
u = u + 1
FillRow y, u
End If
Next
End Sub
Private Sub FillRow(rowFrom As Long, rowTo As Long)
Dim x As Integer
For x = 1 To UBound(arrOneMan, 2)
arrOneMan(rowTo, x) = arrMain(rowFrom, x)
Next
End Sub
Private Function GetDicMan(arr As Variant) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim y As Long
For y = 2 To UBound(arr, 1)
dic.Item(arr(y, MAN_COLUMN)) = 0
Next
Set GetDicMan = dic
End Function
Иван, здравствуйте Разделение таблицы по разным листам — это инструмент из надстройки автора сайта, но по этому запросу можно найти кучу других готовых решений
У меня Эксель на мак и эта настройка у меня как-то криво вставала.
МатросНаЗебре, а можно подгрузить файлы примера, что бы смог разобраться как его настраивать?
Сейчас попробую, спасибо А в какой файл только это вставлять? В тот в котором все данные и будут формироваться новые файлы самостоятельно? Или в тот файл, куда надо будет перетягивать данные? Тогда как быть с основным файлом с данными? Мне больше эта часть вопроса непонятна
думаю еще вариант с формулой попробовать. Посчитать строчку с продажей каждого менеджера в отдельном столбце, что бы получилось уникальные имена: Попов1 Попов2 Попов3
.... и так далее... и по ним уже тупо сВПРить все столбцы. Но у меня на сегодняшний день уже больше 500 тыс строк))) и как быстро это все работать будет, слабо представляю
Можно вставить в любой файл. Например, создайте пустой файл. Вставьте в него код. Сохраните, например, в пустую папку.
Откройте файл с данными. В примере это был файл Пример планета_6.xlsx. Запустите макрос MakeManagersFiles. (Alt+F8 ...). В папку, в которой расположен файл с макросом, будут сохранены файлы по менеджерам.
Надо выделить столбец 21 или все диапазоны, которые надо перенести включая столбец 21? Если просто столбец выделить, то ничего не происходить А если выделить все диапазоны, включая 21-й столбец, то выскакиевает ошибка (скрин приложил)
А выделяете какое-то определённое количество строк? В смысле не столбец целиком? Например, 21 столбец и 100 строк?
А ошибка из снимка экрана какая-то неожиданная. Пишет, что нет лицензии на какой-то компонент. Хотя все компоненты входят в стандартную поставку. А в чём работаете? В Excel?
тогда происходит выделение всего указанного диапазона и та же ошибка Видимо с маком оно не дружит (с некотрыми макросами такое случалось уже). Либо не работали вообще, либо работали очень криво
Попробовал убрать selection. Вместо выделения, станьте на верхний левый угол диапазона. Если не сработает, нужно будет поспрашивать у знающих Mac людей, например, на этом же форуме, как адаптировать.
Код
Option Explicit
Const MAN_COLUMN = 21
Dim rnMain As Range
Dim arrMain As Variant
Dim arrOneMan As Variant
Sub MakeManagersFiles()
'Range("A2:H271").Select
Set rnMain = GetMainRange()
JobMainRange
End Sub
Private Function GetMainRange() As Range
Dim rn As Range
With ActiveSheet
Dim y As Long
y = .Cells(.Rows.Count, ActiveCell.Column).End(xlUp).Row
Set GetMainRange = .Range(ActiveCell, .Cells(y, ActiveCell.Column + MAN_COLUMN - 1))
End With
End Function
Private Sub JobMainRange()
If rnMain.Columns.Count < MAN_COLUMN Then Exit Sub
arrMain = rnMain
Dim dicMan As Object
Set dicMan = GetDicMan(arrMain)
Dim man As Variant
For Each man In dicMan.Keys
FillArrOneMan man
JobNewWb man
Next
End Sub
Private Sub JobNewWb(ByVal man As String)
Application.StatusBar = man
Dim wb As Workbook
Set wb = Workbooks.Add(1)
With wb.Sheets(1).Cells(1, 1).Resize(UBound(arrOneMan, 1), UBound(arrOneMan, 2))
.NumberFormat = "@"
.Value = arrOneMan
.NumberFormat = "General"
Dim x As Integer
For x = 1 To .Columns.Count
.Columns(x).ColumnWidth = rnMain.Columns(x).ColumnWidth
Next
End With
Dim sFull As String
sFull = ThisWorkbook.Path & "\" & man & ".xlsx"
On Error Resume Next
Workbooks(man & ".xlsx").Close False
Kill sFull
Err.Clear
wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If Err = 0 Then
wb.Close False
Else
wb.Saved = True
End If
On Error GoTo 0
Application.StatusBar = False
End Sub
Private Sub FillArrOneMan(ByVal man As String)
ReDim arrOneMan(1 To UBound(arrMain, 1), 1 To UBound(arrMain, 2))
FillRow 1, 1
Dim y As Long
Dim u As Long
u = 1
For y = 2 To UBound(arrMain, 1)
If arrMain(y, MAN_COLUMN) = man Then
u = u + 1
FillRow y, u
End If
Next
End Sub
Private Sub FillRow(rowFrom As Long, rowTo As Long)
Dim x As Integer
For x = 1 To UBound(arrOneMan, 2)
arrOneMan(rowTo, x) = arrMain(rowFrom, x)
Next
End Sub
Private Function GetDicMan(arr As Variant) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim y As Long
For y = 2 To UBound(arr, 1)
dic.Item(arr(y, MAN_COLUMN)) = 0
Next
Set GetDicMan = dic
End Function
'Без словаря.
Option Explicit
Const MAN_COLUMN = 21
Dim rnMain As Range
Dim arrMain As Variant
Dim arrOneMan As Variant
Sub MakeManagersFiles()
'Range("A2:H271").Select
Set rnMain = GetMainRange()
JobMainRange
End Sub
Private Function GetMainRange() As Range
Dim rn As Range
With ActiveSheet
Dim y As Long
y = .Cells(.Rows.Count, ActiveCell.Column).End(xlUp).Row
Set GetMainRange = .Range(ActiveCell, .Cells(y, ActiveCell.Column + MAN_COLUMN - 1))
End With
End Function
Private Sub JobMainRange()
If rnMain.Columns.Count < MAN_COLUMN Then Exit Sub
arrMain = rnMain
Dim dicMan As Variant
dicMan = GetDicMan(arrMain)
Dim man As Variant
For Each man In dicMan
FillArrOneMan man
JobNewWb man
Next
End Sub
Private Sub JobNewWb(ByVal man As String)
Application.StatusBar = man
Dim wb As Workbook
Set wb = Workbooks.Add(1)
With wb.Sheets(1).Cells(1, 1).Resize(UBound(arrOneMan, 1), UBound(arrOneMan, 2))
.NumberFormat = "@"
.Value = arrOneMan
.NumberFormat = "General"
Dim x As Integer
For x = 1 To .Columns.Count
.Columns(x).ColumnWidth = rnMain.Columns(x).ColumnWidth
Next
End With
Dim sFull As String
sFull = ThisWorkbook.Path & "\" & man & ".xlsx"
On Error Resume Next
Workbooks(man & ".xlsx").Close False
Kill sFull
Err.Clear
wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
If Err = 0 Then
wb.Close False
Else
wb.Saved = True
End If
On Error GoTo 0
Application.StatusBar = False
End Sub
Private Sub FillArrOneMan(ByVal man As String)
ReDim arrOneMan(1 To UBound(arrMain, 1), 1 To UBound(arrMain, 2))
FillRow 1, 1
Dim y As Long
Dim u As Long
u = 1
For y = 2 To UBound(arrMain, 1)
If arrMain(y, MAN_COLUMN) = man Then
u = u + 1
FillRow y, u
End If
Next
End Sub
Private Sub FillRow(rowFrom As Long, rowTo As Long)
Dim x As Integer
For x = 1 To UBound(arrOneMan, 2)
arrOneMan(rowTo, x) = arrMain(rowFrom, x)
Next
End Sub
Private Function GetDicMan(arr As Variant) As Variant
Dim dic As Variant
Dim y As Long
For y = 2 To UBound(arr, 1)
If Not ExistsInArr(dic, arr(y, MAN_COLUMN)) Then
If IsEmpty(dic) Then
ReDim dic(0 To 0)
Else
ReDim Preserve dic(LBound(dic) To UBound(dic) + 1)
End If
dic(UBound(dic)) = arr(y, MAN_COLUMN)
End If
Next
GetDicMan = dic
End Function
Private Function ExistsInArr(arr As Variant, vl As Variant) As Boolean
If Not IsEmpty(arr) Then
Dim v As Variant
For Each v In arr
If v = vl Then
ExistsInArr = True
Exit For
End If
Next
End If
End Function
думаю еще вариант с формулой попробовать. Посчитать строчку с продажей каждого менеджера в отдельном столбце, что бы получилось уникальные имена: Попов1 Попов2 Попов3
.... и так далее... и по ним уже тупо сВПРить все столбцы. Но у меня на сегодняшний день уже больше 500 тыс строк))) и как быстро это все работать будет, слабо представляю
В общем решил сделать таким образом. Да, считает очень долго, но потом данные проще обрабатывать, так как у меня там файл с несколькими вкладками можно сделать и обновлять при получении новых данных
За маркросы спасибо, пригодились немного в другой работе )