Страницы: 1
RSS
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
День добрый

Имеется файл с отчетом продажам менеджеров. Одна строка - одна продажа.
необходимо провести сортировку по менеджерам и разнести все данные по разным файлам. Один менеджер - один файл
То есть если взять Исходную таблицу, сделать фильтр по менеджерам, скопировать все данные и вставить их в новую таблицу. Только, что бы это делалось автоматом и обновлялось при дополнении данными в исходном файле
Изменено: Иван - 18.01.2022 08:47:47
 
Иван, здравствуйте
Разделение таблицы по разным листам — это инструмент из надстройки автора сайта, но по этому запросу можно найти кучу других готовых решений
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Ещё вариант.
Код
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
 
Цитата
Иван, здравствуйте
Разделение таблицы по разным листам — это инструмент из надстройки автора сайта, но по этому запросу можно найти кучу других готовых решений
У меня Эксель на мак и эта настройка у меня как-то криво вставала.

МатросНаЗебре, а можно подгрузить файлы примера, что бы смог разобраться как его настраивать?
 
Подгрузить не получается. Думаю, поможет это:
Как вставить готовый макрос в рабочую книгу (office-guru.ru)
Листайте до "Как добавить готовый макрос в рабочую книгу".

Разобраться просто.
Макрос сейчас работает по фиксированному диапазону "A2:H271".
Удалите в коде строку
Код
Range("A2:H271").Select

И макрос будет работать по выделенному диапазону.
 
Сейчас попробую, спасибо
А в какой файл только это вставлять?
В тот в котором все данные и будут формироваться новые файлы самостоятельно?
Или в тот файл, куда надо будет перетягивать данные? Тогда как быть с основным файлом с данными?
Мне больше эта часть вопроса непонятна
 
думаю еще вариант с формулой попробовать.
Посчитать строчку с продажей каждого менеджера в отдельном столбце, что бы получилось уникальные имена:
Попов1
Попов2
Попов3

.... и так далее... и по ним уже тупо сВПРить все столбцы.
Но у меня на сегодняшний день уже больше 500 тыс строк))) и как быстро это все работать будет, слабо представляю  
Изменено: Иван - 18.01.2022 11:15:24
 
Можно вставить в любой файл.
Например, создайте пустой файл. Вставьте в него код.
Сохраните, например, в пустую папку.

Откройте файл с данными. В примере это был файл Пример планета_6.xlsx.
Запустите макрос MakeManagersFiles. (Alt+F8 ...).
В папку, в которой расположен файл с макросом, будут сохранены файлы по менеджерам.
 
Цитата
написал:
думаю еще вариант с формулой попробовать.
Цитата
написал:
Но у меня на сегодняшний день уже больше 500 тыс строк))) и как быстро это все работать будет, слабо представляю
Работать будет медленно. Лучше чуть поднапрячься и освоить макрос.
 
Код
Const MAN_COLUMN = 8

Я правильно понимаю, что тут мы указываем номер столбца, где менеджеры указана, по которым будет идти разбивка?

Вставил макрос
Изменил следующие строки:
Код
Const MAN_COLUMN = 8

8 изменил на 21, так как в реальном отчете колонка с именами менеджеров находится в 21-м столбце

строку

Код
Range("A2:H271").Select

просто удалил
в строке:
Код
If rnMain.Columns.Count < 8 Then Exit Sub

8 изменил тоже на 21

Сохранил, запустил и ничего не произошло (
Что я пропустил?
Изменено: vikttur - 30.01.2022 20:19:46
 
Выделили диапазон?
Тот, в котором 21 столбец?
 
Надо выделить столбец 21 или все диапазоны, которые надо перенести включая столбец 21?
Если просто столбец выделить, то ничего не происходить
А если выделить все диапазоны, включая 21-й столбец, то выскакиевает ошибка (скрин приложил)
 
А выделяете какое-то определённое количество строк?
В смысле не столбец целиком?
Например, 21 столбец и 100 строк?

А ошибка из снимка экрана какая-то неожиданная. Пишет, что нет лицензии на какой-то компонент. Хотя все компоненты входят в стандартную поставку.
А в чём работаете? В Excel?
 
Цитата
А выделяете какое-то определённое количество строк?
В смысле не столбец целиком?
В первом случае выделяю 21-й столбец и 4800 строк
Во втором случае: просто всю таблицу

Цитата
А в чём работаете? В Excel?
Да, Эксель для мака (подписка 365). Лецинзинная и платная подписка
 
А без изменений кода на первоначальном примере работает?

Как вариант можно попробовать не удалять строку
Код
Range("A2:H271").Select

а изменить в ней диапазон.
 
тогда происходит выделение всего указанного диапазона и та же ошибка
Видимо с маком оно не дружит (с некотрыми макросами такое случалось уже). Либо не работали вообще, либо работали очень криво
 
Попробовал убрать 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
Изменено: МатросНаЗебре - 18.01.2022 13:51:26
 
Цитата
написал:
МатросНаЗебре , на огрызке нет словаря!
Была у меня такая гипотеза, теперь она превратилась в аксиому )
 
Цитата
думаю еще вариант с формулой попробовать.
Посчитать строчку с продажей каждого менеджера в отдельном столбце, что бы получилось уникальные имена:
Попов1
Попов2
Попов3

.... и так далее... и по ним уже тупо сВПРить все столбцы.
Но у меня на сегодняшний день уже больше 500 тыс строк))) и как быстро это все работать будет, слабо представляю  
В общем решил сделать таким образом.
Да, считает очень долго, но потом данные проще обрабатывать, так как у меня там файл с несколькими вкладками можно сделать и обновлять при получении новых данных

За маркросы спасибо, пригодились немного в другой работе )
 
МатросНаЗебре, да, на Mac нет Dictionary, но есть Collection
Изменено: New - 30.01.2022 21:23:50
Страницы: 1
Наверх