Страницы: 1
RSS
Разнесение данных с сводных таблиц по отдельным документам
 
Доброго времени суток!

Появился следующий вопрос при обработке однотипных сводных таблиц.

Имеются три сводные таблицы с данными (в приложенных файлах 2022, 2023, 2024), выполнены в одном формате.
Задача: разнести строки с данными из сводных таблиц по данным из первого столбца каждой из них, в отдельные документы (в приложенных документах а1.1.2.1, а1.1.2.2, а1.2.1.1, а1.3.1.2) с делением по годам. Наименование файлов в которые необходимо вставить данные, именуются также как данные столбца 1 в сводных таблицах.

На данный момент процесс переноса данных происходит вручную путем фильтрации в сводных таблицах по первому столбцу и копирование выделенных данных в соответствующий документ.

Возможно есть какие либо способы как-то возможно автоматизировать данный процесс.
 
Цитата
Thadeus написал:
Возможно есть какие либо способы как-то возможно автоматизировать данный процесс.
возможно, с помощью макроса задача вполне решаема, но...
Цитата
Thadeus написал:
На данный момент процесс переноса данных происходит вручную
если операция не разовая, необходимо какое-то доп.условие, метка, диапазон в пределах которого будет производится перенос данных и уточнить куда будут добавляться, (по умолчанию - обычно в конец), если, конечно, не переносить весь объем, т.е. вычищать полностью старые записи и заносить все по-новой...
в принципе, если объем небольшой, то можно и все, иначе, сами понимаете...
Изменено: BodkhiSatva - 12.01.2025 16:20:07
 
Цитата
написал:
если операция не разовая, необходимо какое-то доп.условие, метка, диапазон в пределах которого будет производится перенос данных и уточнить куда будут добавляться
метка - это данные первого столбца (т.е. а1.1.2.1, а1.1.2.2, а1.2.1.1, а1.3.1.2 и т.п.), они в точности совпадают с наименованиями файлов в которые необходимо соответствующие строки переложить.
строки добавляются в конец, друг за другом. (т.е. например в файл а1.1.2.1 переложить все строки "а1.1.2.1" из сводных документов 2022, 2023, 2024, аналогично по другим строкам)
 
"товарищ не понимает" (с)
Цитата
Thadeus написал:
метка - это данные первого столбца (т.е. а1.1.2.1, а1.1.2.2, а1.2.1.1, а1.3.1.2 и т.п.)...
я не про это и в 1-м сообщении это уже написано...ладно, спросим по другому
1. Перенос и распределение надо будет сделать 1 раз? (Хотя, если считать, что 2022, 2023 это годы, то скорее всего да, но...)
2. Если это надо будет делать не 1 раз, в случае добавления новых строк - как отличать новые записи от старых уже перенесенных?
3. Сколько строк в исходной таблице?

Цитата
Thadeus написал:
На данный момент процесс переноса данных происходит вручную путем фильтрации в сводных таблицах по первому столбцу и копирование выделенных данных в соответствующий документ.
эээммм... еще не все перенесли? ;)
Изменено: BodkhiSatva - 12.01.2025 23:16:04
 
Здравствуйте.
Вариант, собрать всё в одном файле и не прыгать по разным книгам.
Выбор на листе "Все". При выборе кода на листе "Все" в ячейке N1, на листах 2022; 2023 и 2024 будут формироваться таблицы в соответствии с выбором.
Можно оставить лист "Все" вместо листов по годам, и формировать таблицу по выбору года в N2 и кода в N1.
Если нужна отдельная книга, можно сохранить любой лист отдельно и разорвать связи.
Изменено: gling - 13.01.2025 00:17:14
 
Цитата
написал:
1. Перенос и распределение надо будет сделать 1 раз?

Прошу прощения, недопонял сразу, да, надо сделать один раз.

Цитата
написал:
3. Сколько строк в исходной таблице?
в каждой из трех порядка 11000

Цитата
написал:
эээммм... еще не все перенесли?
еще нет)
 
Цитата
написал:
Здравствуйте.Вариант, собрать всё в одном файле и не прыгать по разным книгам. Выбор на листе "Все". При выборе кода на листе "Все" в ячейке N1, на листах 2022; 2023 и 2024 будут формироваться таблицы в соответствии с выбором. Можно оставить лист "Все" вместо листов по годам, и формировать таблицу по выбору года в N2 и кода в N1. Если нужна отдельная книга, можно сохранить любой лист отдельно и разорвать связи.
Спасибо большое, интересный вариант, но тут важны именно отдельные файлы (которых более 200) в которых, в последствии после сбора строк будут выполнятся свои вычисления.
 
Код
Option Explicit
Sub Разнести_выделенный_диапазон()
    CloseEmptyWb
    
    Dim rSource As Range
    Set rSource = Selection
    
    Dim dic As Object
    Set dic = GetDic(rSource)
    If dic.Count = 0 Then Exit Sub
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim wbSource As Workbook
    Set wbSource = rSource.Parent.Parent
    
    Dim vFile As Variant
    For Each vFile In dic.Keys
        SaveDataFile wbSource.Path, vFile, dic(vFile), fso.GetBaseName(wbSource.Name), rSource.Rows(2)
    Next
End Sub

Private Sub SaveDataFile(sPath As String, ByVal sMask As String, brr As Variant, sheet_name As String, template_row As Range)
    Dim arr As Variant
    arr = GetTwoDimArray(brr)
    If IsEmpty(arr) Then Exit Sub
    
    Dim wb As Workbook
    Dim sName As String
    sName = Dir(sPath & "\" & sMask & ".xlsx", vbNormal)
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    Dim needClose As Boolean
    If wb Is Nothing Then
        If sName = "" Then
            Set wb = Workbooks.Add(1)
            wb.Sheets(1).Name = sheet_name
            needClose = False
        Else
            Set wb = Workbooks.Open(sPath & "\" & sName)
            needClose = True
        End If
    Else
        needClose = False
    End If
    
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = wb.Sheets(sheet_name)
    On Error GoTo 0
    If sh Is Nothing Then
        wb.Sheets.Add After:=wb.Sheets(wb.Sheets.Count)
        wb.Sheets(wb.Sheets.Count).Name = sheet_name
        Set sh = wb.Sheets(sheet_name)
    End If
    
    SaveDataSheet sh, arr, template_row
    If needClose Then
        wb.Close True
    End If
End Sub

Private Sub SaveDataSheet(sh As Worksheet, arr As Variant, template_row As Range)
    With sh
        Dim ys As Long, rr As Range
        ys = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
        Set rr = .Cells(ys, 2)
        Set rr = rr.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
    End With
    
    template_row.Copy rr
    rr.Value = arr
End Sub

Private Function GetTwoDimArray(brr As Variant) As Variant
    Dim ya As Long, xa As Long
    For ya = LBound(brr) To UBound(brr)
        If xa < UBound(brr(ya)) Then xa = UBound(brr(ya))
    Next
    If xa = 0 Then Exit Function
    
    Dim arr As Variant
    ReDim arr(1 To UBound(brr), 1 To xa)
    For ya = LBound(brr) To UBound(brr)
        For xa = LBound(brr(ya)) To UBound(brr(ya))
            arr(ya, xa) = brr(ya)(xa)
        Next
    Next
    GetTwoDimArray = arr
End Function

Private Function GetDic(rSource As Range) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim arr As Variant
    arr = Intersect(rSource, rSource.Parent.UsedRange).Value
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If arr(ya, 1) <> "" Then
            AddRow dic, arr(ya, 1), arr, ya
        End If
    Next
    
    Set GetDic = dic
End Function

Private Sub AddRow(dic As Object, ByVal sKey As String, arr As Variant, ya As Long)
    Dim brr As Variant, crr As Variant
    If Not dic.Exists(sKey) Then
        ReDim brr(1 To 1)
        dic(sKey) = brr
    Else
        brr = dic(sKey)
        ReDim Preserve brr(LBound(brr) To UBound(brr) + 1)
    End If
    
    ReDim crr(1 To UBound(arr, 2))
    Dim xa As Long
    For xa = 1 To UBound(crr)
        crr(xa) = arr(ya, xa)
    Next
    brr(UBound(brr)) = crr
    crr = Empty

    dic(sKey) = brr
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub
 
Цитата
Thadeus написал:
важны именно отдельные файлы (которых более 200)
оба-на.... т.е. этих "а1.1.2.1" и т.д. более 200 вариантов??  8-0
если это так, то становится понятна ваша озабоченность... и, кстати, это надо было сразу обговаривать...
а то я уж подумал: "эка невидаль, раскидать таблицу по 4 файлам... хех... ;))))"
 
Цитата
написал:
оба-на.... т.е. этих "а1.1.2.1" и т.д. более 200 вариантов??  
Да, это так, их более 200..., работа хоть и разовая, но будет выполнятся каждый год и с новыми сводными таблицами. Первый раз с подобной обработкой информации столкнулся, поэтому пытаюсь по возможности как-то автоматизировать процесс.
 
Thadeus,
Попробуйте такой вариант.
Все исходные файлы в одной папке.
В файлы 2022, 2023 и 2024 вставить стандартный модуль и поочередно запустить макрос
Код
Option Explicit

Sub iName_a1()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim iName As String
Dim iListName As String
Dim Wb As Workbook
Dim iSh As Worksheet
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Range("M1:M" & iLastRow).Clear
    Range("B2:B" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("M2"), Unique:=True
    Range("M2") = "Уникальные номера"
    iListName = Split(ActiveWorkbook.Name, ".")(0)  'лист по названию активной книги
     Set iSh = ThisWorkbook.Worksheets("Лист1")
   For i = 3 To Cells(Rows.Count, "M").End(xlUp).Row
     iName = Cells(i, "M")
       'проверяем есть файл с таким именем в папке с текущим файлом
     If FileExists(ThisWorkbook.Path & "\" & iName & ".xlsx") Then     'есть такой файл
        If ActiveSheet.AutoFilterMode = False Then
            Range("B2:K2").AutoFilter
        Else
            If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
        End If
      Set Wb = Workbooks.Open(FileName:=ThisWorkbook.Path & "\" & iName & ".xlsx")
        Wb.Worksheets(iListName).Activate
          iLR = Cells(Rows.Count, "B").End(xlUp).Row + 1
          With iSh.AutoFilter.Range
            .Range("B2").AutoFilter Field:=1, Criteria1:=iName
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy Cells(iLR, 2)
          End With
        Wb.Close saveChanges:=True
        If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
     Else
       MsgBox "В папке с исходным файлом нет файла: " & ThisWorkbook.Path & "\" & iName & ".xlsx"
     End If
   Next
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
  End With
End Sub


'Проверка существования файла
Function FileExists(ByVal FileName As String) As Boolean
   FileExists = Len(Dir(FileName)) > 0
End Function
 
"... их более 200..., работа разовая, но будет выполнятся каждый год" - похоже, задача решается не техническим, а организационным методом...
 
Цитата
Kuzmich написал:
В файлы 2022, 2023 и 2024 вставить стандартный модуль и поочередно запустить макрос
Цитата
BodkhiSatva написал:
этих "а1.1.2.1" и т.д. более 200 вариантов
надо бы расшить макрос, добавить в проверку наличия файла и листа года в нем и если чего-то нет, то создать новый файл, а в нем лист по году с шапкой таблицы. Иначе придется вручную создавать файлы >200 шт...
у меня с макросами не очень быстро получается их писать...  :(
Изменено: BodkhiSatva - 13.01.2025 17:39:53
 
BodkhiSatva, написал
Цитата
надо бы расшить макрос, добавить в проверку наличия файла и листа года в нем
Проверка на наличие файла в макросе есть, а если делать все проверки,  то ТС делать будет нечего
 
Цитата
Kuzmich написал:
Проверка на наличие файла в макросе есть, а если делать все проверки,  то ТС делать будет нечего
ага... и чтобы ТС не скучал нехай каждый раз запускает макрос, смотрит какого файла нет, создает этот файл, переименовывает лист, копирует в него шапку и запускает макрос по-новой...
ну дык.... ему же делать все равно нечего... )))
 
Цитата
написал:
Попробуйте такой вариант.
Спасибо буду пробовать
 
Цитата
написал:
надо бы расшить макрос, добавить в проверку наличия файла и листа года в нем и если чего-то нет, то создать новый файл,
... как например сделано в сообщении #8.
 
Thadeus, написал
Цитата
Да, это так, их более 200..., работа хоть и разовая, но будет выполнятся каждый год и с новыми сводными таблицами. Первый раз с подобной обработкой информации столкнулся, поэтому пытаюсь по возможности как-то автоматизировать процесс.
Посмотрите в файле Образец я написал макрос, позволяющий создать эти 200 файлов с разным количеством листов в той же папке, где и сходный файл.
Думаю, что в купе с вышеприведенным макросом это поможет существенно автоматизировать рабочий процесс, удачи!
 
https://www.youtube.com/watch?v=sL6xcZkD7Ss Первый же способ.
А если ещё этим (https://akademia-excel.ru/blog/920500) дополнить...
Изменено: Сергей Лисицын - 17.01.2025 13:51:57
Страницы: 1
Наверх