Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Объединение сгруппированных таблиц
 
#1
15.07.2020 09:02:42
Доброго времени суток! Помогите пожалуйста, голову сломал.
Имеется несколько книг, выгружаются из 1С.  Исходные таблицы сгруппированы. Обычная консолидация не подходит, т.к. имеются одинаковые записи в разных группах. Необходимо их объединить с сохранением структуры.
Заранее спасибо за помощь!!!
 
 
 
#2
15.07.2020 13:30:48
Сергей Малахов, Покажите как должно быть
 
 
 
#3
15.07.2020 17:11:37
msi2102,Шапка документа особой роли не играет.  
 
 
 
#4
15.07.2020 22:44:17
Сергей Малахов,  времен не было проверять ну примерно так...еще нужно добавить проверку второй книги на наличие контрагентов которых нет в первой книге.
вдруг кто-то поможет более простым решением, если нет возможно завтра попробую.
и кстати у вас наименование контрагента отлично бывает где-то с пробелом где-то без.
Код
Sub dsd()
Dim i As Long
Dim lr As Long
Dim cell As Range
Dim wb As Workbook, wb2 As Workbook
Set wb = Workbooks("Оборотно-сальдовая ведомость по счету 76.09 за Апрель")
Set wb2 = Workbooks("Оборотно-сальдовая ведомость по счету 76.09 за Май")
lr = wb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
lr2 = wb2.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 9 Step -1
    If wb.Worksheets(1).Cells(i, 1) <> "Итого" Then
    If wb.Worksheets(1).Range("A" & i).Rows(1).OutlineLevel = 2 Then
        x = Application.WorksheetFunction.Trim(wb.Worksheets(1).Range("A" & i))
        Set cell = wb2.Worksheets(1).Range("A:B").Find(x, LookAt:=xlPart)
    On Error Resume Next
        For k = cell.Row + 1 To lr2
            If wb2.Worksheets(1).Range("A" & k).Rows(1).OutlineLevel <> 3 Then
                Rows(i + 1 & ":" & i + k - cell.Row - 1).EntireRow.Insert
                wb2.Worksheets(1).Range("A" & cell.Row + 1 & ":I" & k - 1).Copy _
                Destination:=wb.Worksheets(1).Range("A" & i + 1 & ":I" & i + k - cell.Row - 1)
                Exit For
            End If
        Next k
    End If
    End If
Next i
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#5
16.07.2020 03:54:33
Mershik,  "еще нужно добавить проверку второй книги на наличие контрагентов которых нет в первой книге." - помогите пожалуйста с этим
"у вас наименование контрагента отлично бывает где-то с пробелом где-то без" - спасибо что сказали.
Если мне надо объединить более 2х таблиц, можно же просто объявить переменные wb3 и Ir и подправить цикл?
Спасибо больше за помощь!
Изменено: Сергей Малахов - 16.07.2020 09:00:10
 
 
 
#6
17.07.2020 22:59:26
Доброго времени суток!
Не смог добавить проверку второй книги и добавление более 2х книг.
Помогите пожалуйста!!!
 
 
 
#7
18.07.2020 21:38:16
Сергей Малахов,  дд. Создаете книгe c названием СВОД в формате .xlsm туда в модуль вставляете макрос (НЕ СЧИТАЕТ СУММЫ ПО КОНТРАГЕНТУ):
Код
Sub svod()
Dim oWB As Workbook, oWB2 As Workbook
Dim lr As Long, i As Long, lr2 As Long
Dim cell As Range
Application.ScreenUpdating = False
Set oWB2 = Workbooks("СВОД")
With oWB2
.Worksheets(1).Range("A:A").ClearOutline
.Worksheets(1).Range("A:Z").Clear

For Each oWB In Workbooks
    If oWB.Name <> "СВОД.xlsm" And oWB.Name <> "PERSONAL.XLSB" Then
        oWB.Activate
        Range("A:B").UnMerge
        lr = oWB.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        oWB.Worksheets(1).Cells(8, 1) = Mid(oWB.Worksheets(1).Cells(1, 1), InStr(1, oWB.Worksheets(1).Cells(1, 1), "за "), 99)
        oWB.Worksheets(1).Rows("8:" & lr).Copy
        .Activate
        lr = .Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Worksheets(1).Cells(lr, 1).Select
        ActiveSheet.Paste
    End If
Next oWB

Columns(3).EntireColumn.Insert
lr2 = .Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = lr2 To 1 Step -1
    If .Worksheets(1).Range("A" & i).Rows(1).OutlineLevel = 1 Then
        .Worksheets(1).Range("C" & i & ":C" & i + k).Value = .Worksheets(1).Range("A" & i)
        k = 0
    End If
        k = k + 1
Next i

For i = lr2 To 3 Step -1
    If .Worksheets(1).Range("A" & i).Rows(1).OutlineLevel = 2 Then
        x = Application.WorksheetFunction.Trim(.Worksheets(1).Range("A" & i))
        Set cell = .Worksheets(1).Range("A" & i - 1 & ":B" & 2).Find(x, LookAt:=xlWhole)
        If Not cell Is Nothing Then
            For f = cell.Row + 1 To lr2
            If .Worksheets(1).Range("A" & f).Rows(1).OutlineLevel <> 3 Then
                Rows(i + 1 & ":" & i + f - cell.Row - 1).EntireRow.Insert
                .Worksheets(1).Rows(cell.Row + 1 & ":" & f - 1).Copy _
                Destination:=.Worksheets(1).Rows(i + 1 & ":" & i + f - cell.Row - 1)
                .Worksheets(1).Rows(cell.Row & ":" & f - 1).Delete
                Exit For
            End If
            Next f
        End If
    End If
Next i

lr2 = .Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = lr2 To 1 Step -1
    If .Worksheets(1).Range("A" & i).Rows(1).OutlineLevel = 1 Then .Worksheets(1).Rows(i & ":" & i).Delete
Next i
End With
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 18.07.2020 21:45:14
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#8
19.07.2020 13:48:54
Mershik, Спасибо большое! Очень благодарен!
 
 
 
#9
20.07.2020 05:05:59
Mershik, Здравствуйте! Хотел проверить на новом файле появилась ошибка. Скрины приложил. Файл на котором пробовал приложил. Причем сначала на файлах Апрель и Май работало. Потом перестало.
 
 
 
#10
20.07.2020 05:58:40
Разобрался!
 
 
 
Страницы: 1
Наверх