Новости:

Теперь на форум можно залогиниться / зарегистрироваться с помощью ВКонтакте. Уже существующие пользователи могут связать свою учетную запись с аккаунтом ВКонтакте одним кликом в профиле пользователя http://forum.msexcel.ru/index.php?action=profile;area=account

Главное меню

Сведение данных из разных листов/файлов в единую таблицу.

Автор Dmitry, 23.07.2013, 02:10

« назад - далее »

Dmitry

Т.к. из-за разности часовых поясов, я не успел прикрепить файл после предупреждения и тему закрыли. Я ее создаю заново, уже с файлом.

Суть проблемы в том, что при выгрузке из 1С есть куча файлов которые собраны вручную в одной книге, но на разных листах. Надо каким то образом задать функцию или макрос, чтоб excel собрал все данные в одну единую таблицу, на пустом листе (можно даже в новой книге). Загвоздка заключается в том что количество строк в исходных данных может быть разным. (одна позиция не была в январе, появилось в марте и т.д.).  Надо, чтоб при сборе данных на новый лист excel сам добавлял строку, которая в других листах не была отражена. Таблица будет - слева название, а в право с разбивкой по месяцам колонки.

Подскажите есть у кого то такой макрос или может кто то стандартными средствами решал такую задачу?

GWolf

Доброго дня!
На скрепке решение. Код, может быть и не совсем оптимален, но работает. Не стал встраивать в Ваш макрос. Мне показалось что в два этапа: сначала собрать в книгу листы, а затем из листов создать сборный лист - решение более рабочее.
Если будут вопросы - обращайтесь.
Путей к вершине - множество. Этот один из многих!

Sarytai

Знаете, я бы посоветовал вам при выгрузке вытащить еще и уникальный код (артикул или еще что) каждому наименованию и группе. В этом случае ушла бы куча ручной работы. Я бы потом на вашем месте присвоил каждому полю столбец месяца и объединил в один лист, откуда сформировал бы нужный отчет через сводную таблицу. А в этом виде задача представляет собой тренировку для мозгов и то, боюсь, что просто через рекордер макросов такой макрос будет тяжело сделать.

GWolf

Ну, почему же мы не читаем и не смотрим ответы коллег? Давайте уточним:
Цитата: Sarytai от 23.07.2013, 20:53
... я бы посоветовал вам при выгрузке вытащить еще и уникальный код (артикул или еще что) каждому наименованию и группе. В этом случае ушла бы куча ручной работы.
Согласен, но что делать если "вытащить" по той или иной причине не получается, и обработать отчеты требуется "как есть"? Тогда обучаем макрос присваиванию кодов, что собственно и было реализовано в предложенном мною решении. Просто в результате работы макроса этого не видно, так как он подчищает за собой.
ЦитироватьЯ бы потом на вашем месте присвоил каждому полю столбец месяца и объединил в один лист, откуда сформировал бы нужный отчет через сводную таблицу. А в этом виде задача представляет собой тренировку для мозгов и то, боюсь, что просто через рекордер макросов такой макрос будет тяжело сделать.
Верно, через рекордер и не делал. А все же решаемая задача. Кому интерестно, может запустить макрос по F8 (в режиме отладки) и посмотреть как все решилось.
А так, в общем и целом: "складываем" в данную книгу листы с месячными отчетами, поэтому и добавлен лист с именем "_". Т.к. при удалении листов с отчетами хотя бы один лист должен остаться! Ну и лист "Сводная" после создания следует переместить в другую книгу! По структуре обрабатываемых отчетов, важно, что бы данные начинались с седьмой строки.
Имя макроса: sborka

С уважением GWolf.
Путей к вершине - множество. Этот один из многих!

Dmitry

Цитата: Sarytai от 23.07.2013, 20:53
Знаете, я бы посоветовал вам при выгрузке вытащить еще и уникальный код (артикул или еще что) каждому наименованию и группе. В этом случае ушла бы куча ручной работы. Я бы потом на вашем месте присвоил каждому полю столбец месяца и объединил в один лист, откуда сформировал бы нужный отчет через сводную таблицу. А в этом виде задача представляет собой тренировку для мозгов и то, боюсь, что просто через рекордер макросов такой макрос будет тяжело сделать.

Артикул конечно бы решил эту проблему, но у многих позиций его просто нету...... так, что нет смысла к нему привязываться.

Dmitry

У кого получилось отпишитесь пожалуйста! У меня скаченный файл GWolf работает, в конце не все повторяющиеся строки удаляет. Хотя файл тот же.

shanemac51a

предпочитаю получать единый файл с добавлением столбиков
--имя книги
--или листа
--наименование группы

далее по-ячеечный перенос и сводная

Dmitry

Цитата: shanemac51a от 26.07.2013, 13:03
предпочитаю получать единый файл с добавлением столбиков
--имя книги
--или листа
--наименование группы

далее по-ячеечный перенос и сводная

Идея хорошая, но немного не, то что надо для моих целей.

GWolf

Добрый вечер!
Макрос "допилил"! Смотрите ящик. После проверки планирую выложить сюда.
Путей к вершине - множество. Этот один из многих!

Dmitry

Цитата: GWolf от 31.07.2013, 16:56
Добрый вечер!
Макрос "допилил"! Смотрите ящик. После проверки планирую выложить сюда.

Сейчас проверил. Отписал результат на ящик.

Dmitry

Цитата: Dmitry от 06.08.2013, 09:52
Цитата: GWolf от 31.07.2013, 16:56
Добрый вечер!
Макрос "допилил"! Смотрите ящик. После проверки планирую выложить сюда.

Сейчас проверил. Отписал результат на ящик.

Все посмотрел, все работает, большое спасибо за помощь!!! Благодаря Вам сэкономили кучу времени на перетаскивание по одной цифре в таблицу из кучи отчетов!

GWolf

Доброго дня!
На скрепке крайняя версия макроса.
Ну и на всякий случай, продублирую код:
Sub sborka()
    Dim ws As Object
    Dim iDiapazon As Range
    Dim sht As Worksheet
    Dim flg As Boolean
    Dim nRStart As Long, nREnd As Long, nRBlok As Long, nCBlok As Integer, i As Long, j As Long, k As Long, m As Long
    Dim nmr As String
    Dim stroka1 As String, stroka2 As String
   
    Set ws = ActiveWorkbook.Sheets.Add(Before:=Worksheets(2))
    ws.Name = "Сводная" & Format(Date, "yymmdd") & Format(Time, "hhmmss")
   
    On Error GoTo ErrHandl
    Application.ScreenUpdating = False
   
    nRStart = 8
    nRBlok = 8
    nCBlok = 3
    For Each sht In Worksheets
        If sht.Name <> ws.Name And sht.Name <> "_" And Trim(sht.Name) Like "## ##" Then
            With sht
                Set iDiapazon = .UsedRange
                With iDiapazon
                    nREnd = .Row + .Rows.Count - 1
                End With
                Set iDiapazon = Nothing

                If nREnd > 6 Then
                    Range(.Cells(nRStart, 3), .Cells(nREnd, 3)).Copy _
                        Destination:=ws.Cells(nRBlok, 1)
                    Range(.Cells(nRStart, 1), .Cells(nREnd, 1)).Copy _
                        Destination:=ws.Cells(nRBlok, 2)
                    Range(.Cells(nRStart, 2), .Cells(nREnd, 2)).Copy _
                        Destination:=ws.Cells(nRBlok, nCBlok)

                    nRBlok = nRBlok + (nREnd - nRStart)
                Else
                    MsgBox "На листе " & sht.Name & " данные, вероятно, отсутствуют!", vbInformation + vbOKOnly, "Сообщение макропрограммы:"
                End If
            End With
            'определим и запишем наименование обрабатываемого месяца = Start ===
            ws.Cells(nRStart - 1, nCBlok) = mesTXT(Left(Trim(sht.Name), 2))
            'определим и запишем наименование обрабатываемого месяца = Stop ===
            nCBlok = nCBlok + 1
        End If
    Next

    nRBlok = nRBlok - 1
    nCBlok = nCBlok - 1
   
    With ws
        'копируем список месяцев = Start ===
        Range(.Cells(nRStart - 1, 2), .Cells(nRStart - 1, nCBlok)).Copy _
                        Destination:=.Cells(nRStart - 1, nCBlok + 2)
        'копируем список месяцев = Stop ===
        'соберем в отдельный список все заголовки разделов (уникальные)= Start ===
        k = 0
        i = 0
        For i = nRStart To nRBlok
            If .Cells(i, 2).Font.ColorIndex = 3 Then
                If k = 0 Then '- первое значение
                    Range(.Cells(i, 2), .Cells(i, nCBlok)).Copy _
                        Destination:=.Cells(k + nRStart, nCBlok + 2)
                    k = k + 1
                Else '- все последующие
                    stroka1 = ""
                    stroka1 = .Cells(i, 2).Text
                    'проверим, нет ли этого значения в формируемом списке = Start ===
                    flg = False
                    j = 0
                    For j = nRStart To k + nRStart - 1
                        If .Cells(j, nCBlok + 2).Text = stroka1 Then
                            flg = True: Exit For
                        End If
                    Next j
                    'проверим, нет ли этого значения в формируемом списке = Stop ===
                    If flg = False Then '- значение отсутствует
                        'если значение отсутствуе, то найдем и возьмем в переменную наименование выше _
                         расположенного раздела, чтобы вставить новое значение во вновь формируемый _
                         список ниже этого раздела.
                        j = 0
                        For j = i - 1 To nRStart Step -1
                           If .Cells(j, 2).Font.ColorIndex = 3 Then
                               stroka2 = .Cells(j, 2).Text '- нашли и взяли в переменную
                               Exit For
                           End If
                        Next j
                       
                        j = 0
                        For j = nRStart To k + nRStart - 1
                            If .Cells(j, nCBlok + 2).Text = stroka2 Then
                                If .Cells(j + 1, nCBlok + 2) <> "" Then
                                    Range(.Cells(j + 1, nCBlok + 2), .Cells(j + 1, nCBlok + 2 + (nCBlok - 1))).Insert Shift:=xlDown
                                End If
                                Range(.Cells(i, 2), .Cells(i, nCBlok)).Copy _
                                    Destination:=.Cells(j + 1, nCBlok + 2)
                            End If
                        Next j
                    Else '- уже имеется
                        m = 0
                        For m = 3 To nCBlok
                            If .Cells(i, m).Value <> 0 Then
                                'если уже имеется, то копируем только цифровое значение
                                .Cells(i, m).Copy _
                                    Destination:=.Cells(j, nCBlok + 2 + (m - 2))
                            End If
                        Next m
                    End If
                    k = k + 1
                End If
            End If
        Next i
        'соберем в отдельный список все заголовки разделов (уникальные)= Stop ===
        'наполним собранные разделы уникальным содержимым = Start ===
        stroka1 = "": stroka2 = ""
        i = 0
        For i = nRStart To nRBlok
            If .Cells(i, 2).Font.ColorIndex = xlAutomatic Then '- наименование без цветового выделения
                stroka1 = .Cells(i, 2).Text
                'найдем и возьмем в переменную наименование группы, к которой относится запись
                j = 0
                For j = i To nRStart Step -1
                    If .Cells(j, 2).Font.ColorIndex = 3 Then
                        stroka2 = .Cells(j, 2).Text: Exit For
                    End If
                Next j
                'теперь поищем в списке №2 соответствующую группу (stroka2) и в ее блоке значений _
                 поищем значение (stroka1)
                'Sheets("отчет").Cells(3, 1).End(xlDown).Row + 1
                nRIn = 0 '-строка начала блока
                nROu = 0 '-строка окончания блока
               
                j = 7
                Do
                    j = j + 1
                    If .Cells(j, nCBlok + 2) = stroka2 Then
                        nRIn = j
                    ElseIf .Cells(j, nCBlok + 2).Text = "" Or .Cells(j, nCBlok + 2).Font.ColorIndex = 3 And nRIn > 0 Then
                        nROu = j: Exit Do
                    End If
                Loop While .Cells(j, nCBlok + 2).Text <> ""
               
                If nROu = nRIn + 1 Then
                    Range(.Cells(nROu, nCBlok + 2), .Cells(nROu, nCBlok + 2 + (nCBlok - 1))).Insert Shift:=xlDown
                    Range(.Cells(i, 2), .Cells(i, nCBlok)).Copy _
                            Destination:=.Cells(nROu, nCBlok + 2)
                    nRIn = 0: nROu = 0
                ElseIf nROu > nRIn + 1 Then
                    flg = False: j = 0
                    For j = nRIn + 1 To nROu - 1
                        If .Cells(j, nCBlok + 2) = stroka1 Then
                            flg = True: Exit For
                        End If
                    Next j
                   
                    If flg = False Then
                        Range(.Cells(nROu, nCBlok + 2), .Cells(nROu, nCBlok + 2 + (nCBlok - 1))).Insert Shift:=xlDown
                        Range(.Cells(i, 2), .Cells(i, nCBlok)).Copy _
                                Destination:=.Cells(nROu, nCBlok + 2)
                        nRIn = 0: nROu = 0
                    Else '- уже есть
                        flg = False: m = 0
                        For m = 3 To nCBlok
                            If .Cells(i, m).Text <> "" Then '.Cells(i, m).Font.ColorIndex <> xlNone Then 'And _
                                        .Cells(i, m).Text <> "" Then
                               flg = True: Exit For
                            End If
                        Next m
                       
                        If flg = True Then
                            If .Cells(j, nCBlok + m + 1).Text = "" Then
                                'то просто копируем
                                .Cells(i, m).Copy Destination:=.Cells(j, nCBlok + m)
                            Else 'в противном случае
                                'к уже имеющемуся значению плюсуем вновь найденное
                                .Cells(j, nCBlok + m) = CDbl(.Cells(j, nCBlok + m).Text) + CDbl(.Cells(i, m).Text)
                            End If
                        Else
                        End If
                    End If
                End If
            End If
        Next i
        'наполним собранные разделы уникальным содержимым = Stop ===
        Range(.Columns(1), .Columns(9)).Delete Shift:=xlToLeft
    End With
    ' - // - = Stop ===
    Set ws = Nothing
Application.ScreenUpdating = True

ErrHandl:
    MsgBox Err.Description
    Set ws = Nothing
End Sub

Function mesTXT(mesT As String)
    Select Case mesT
        Case "01"
            mesTXT = "Январь"
        Case "02"
            mesTXT = "Февраль"
        Case "03"
            mesTXT = "Март"
        Case "04"
            mesTXT = "Апрель"
        Case "05"
            mesTXT = "Май"
        Case "06"
            mesTXT = "Июнь"
        Case "07"
            mesTXT = "Июль"
        Case "08"
            mesTXT = "Август"
        Case "09"
            mesTXT = "Сентябрь"
        Case "10"
            mesTXT = "Октябрь"
        Case "11"
            mesTXT = "Ноябрь"
        Case "12"
            mesTXT = "Декабрь"
        Case Else
            mesTXT = "номер месяца неизвестен"
    End Select
End Function
Путей к вершине - множество. Этот один из многих!

leobos

Добрый день,

А возможно ли сделать надстройку для сведения данных в один лист из разных книг? К сожаления с макросами не дружу, а нужно свести однотипную информацию с разных книг в одну таблицу без консолидации.

GWolf

Цитата: leobos от 04.11.2013, 13:16
... А возможно ли сделать надстройку для сведения данных в один лист из разных книг? К сожаления с макросами не дружу, а нужно свести однотипную информацию с разных книг в одну таблицу без консолидации.
Доброго дня!
Сделать возможно все. Вопрос лишь в использованных ресурсах и полученных результатах.
Что бы решить Вашу задачу, можно пойти двумя путями:
1) вникнуть в код, который я выложил. Прямо скажу: решалась нетривиальная задача, так что для освоения программирования самое то. Мне бы в свое время такую подмогу! Ну и с вопросами: - Милости просим!
2) поставить задачу и за денюжку малую получить решение. (То что вы написали как вопрос постановкой задачи не является!)

Ну и общее пожелание: создать под интересующий Вас вопрос отдельную тему!
Путей к вершине - множество. Этот один из многих!