Здравствуйте форумчане. Помогите пожалуйста доделать файл. Надо на лист Семья создать при помощи макроса таблицу с данными с листа Итог. Надо найти совпадающие значения на листе Итог в столбцах Отец, Мать, Адреси если данные совпадают то взять данные из столбца Фамилия Имя Отчествои добавить на лист Семьи. Сделал лист Семьи, как примерно должно выглядеть. Как объяснил и сам толком не понял. Что не понятно поясню.
Здравствуйте форумчане. Помогите пожалуйста доделать файл. Надо на лист Семья создать при помощи макроса таблицу с данными с листа Итог. Надо найти совпадающие значения на листе Итог в столбцах Отец, Мать, Адреси если данные совпадают то взять данные из столбца Фамилия Имя Отчествои добавить на лист Семьи. Сделал лист Семьи, как примерно должно выглядеть. Как объяснил и сам толком не понял. Что не понятно поясню.DrMini
Боюсь, что нет. Дети достигшие совершеннолетия (18 лет) будут удаляться с листа Посетители. Ну и после внесения новых детей каждый раз создавать сводную таблицу очень неудобно.
Боюсь, что нет. Дети достигшие совершеннолетия (18 лет) будут удаляться с листа Посетители. Ну и после внесения новых детей каждый раз создавать сводную таблицу очень неудобно.DrMini
Сообщение отредактировал DrMini - Четверг, 05.07.2018, 12:47
Скажите пожалуйста как обновить таблицу? Выделяю таблицу -> Работа со сводными таблицами -> Анализ -> Обновить. Пишет, что не может найти исходный файл сводной таблицы. Александр, а может всё-таки найдёте время, ну хотя бы после выходных и напишите макрос. С ним думаю было бы значительно удобнее. И надо что бы на листе Семьи обязательно подсчитывалось количество семей.
Скажите пожалуйста как обновить таблицу? Выделяю таблицу -> Работа со сводными таблицами -> Анализ -> Обновить. Пишет, что не может найти исходный файл сводной таблицы. Александр, а может всё-таки найдёте время, ну хотя бы после выходных и напишите макрос. С ним думаю было бы значительно удобнее. И надо что бы на листе Семьи обязательно подсчитывалось количество семей.DrMini
Там же нажмите на кнопку "Источник данных" и посмотрите, что там написано. Должно быть (если по тому файлу, что я приложил) Итог!$C$1:$G$1500 Обновлять еще можно правой мышой в любое место сводной - Обновить
А по поводу макроса думаю, что здесь и без меня умельцев хватает, до выходных Вам 10 раз успеют написать
Там же нажмите на кнопку "Источник данных" и посмотрите, что там написано. Должно быть (если по тому файлу, что я приложил) Итог!$C$1:$G$1500 Обновлять еще можно правой мышой в любое место сводной - Обновить
А по поводу макроса думаю, что здесь и без меня умельцев хватает, до выходных Вам 10 раз успеют написать_Boroda_
DrMini, На странице "Посетители" добавил колонку с формулой, которая считает исполнилось или нет 18 лет, а возле сводной таблицы добавил колонку считающую количество семей. т.к. моя сводная ссылается непосредственно на таблицу "Т1", нет необходимости в промежуточной таблице "Итог"
З.Ы. Добавил фильтр. Теперь в сводной только несовершеннолетние
DrMini, На странице "Посетители" добавил колонку с формулой, которая считает исполнилось или нет 18 лет, а возле сводной таблицы добавил колонку считающую количество семей. т.к. моя сводная ссылается непосредственно на таблицу "Т1", нет необходимости в промежуточной таблице "Итог"
З.Ы. Добавил фильтр. Теперь в сводной только несовершеннолетниеboa
DrMini, Мне не понятно, что сложного в обновлении сводной таблицы, ну дык ладно, макрос, так макрос
[vba]
Код
Option Explicit
Sub FamilyComposition() '' Author: boa '' Written: 05.07.2018 ' Description: формирует таблицу "состав семьи" Dim NewMyArray, MyArray Dim Rng As Range, a As Range Dim MyKey$, i&, iRow& Dim R1, R2, KeysArray(), ItemsArray() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("Посетители").Range("Т1[#All]") On Error Resume Next For Each a In Rng.Rows If Year(Date - CDate(a.Cells(3).Value)) - 1900 < 18 Then 'выбирает только тех кому нет 18 лет MyKey = a.Cells(10).Value & "|" & a.Cells(11).Value & "|" & a.Cells(12).Value If Dic.Exists(MyKey) Then Dic.Item(MyKey) = Dic.Item(MyKey) & "|" & a.Cells(2).Value Else Dic.Add MyKey, a.Cells(2).Value End If End If Next a KeysArray = Dic.Keys ItemsArray = Dic.Items With Application: .ScreenUpdating = False: .EnableEvents = False With Sheets("Семьи") 'лист, на который выгружаются данные .Cells.Clear 'очищаем старые значения For i = LBound(KeysArray) To UBound(KeysArray) iRow = iRow + 1 R1 = Split(KeysArray(i), "|") R2 = Split(ItemsArray(i), "|") .Cells(iRow, 1) = IIf(i = 0, UBound(KeysArray), i) 'номер семьи .Range(.Cells(iRow, 2), .Cells(iRow, 4)) = R1 'родители, адрес .Range(.Cells(iRow + 1, 2), .Cells(iRow + UBound(R2) + 1, 2)) = Application.Transpose(R2) 'дети With .Range(.Cells(iRow, 1), .Cells(iRow, 4)) .Interior.Color = vbBlack 'цвет заливки .Font.Color = vbWhite 'цвет шрифта End With iRow = iRow + UBound(R2) + 2 ' если не желаете, что бы между семьями добавлялась пустая строка - замените 2 на 1 Next .Select End With .ScreenUpdating = True: .EnableEvents = True: End With End Sub
[/vba]
DrMini, Мне не понятно, что сложного в обновлении сводной таблицы, ну дык ладно, макрос, так макрос
[vba]
Код
Option Explicit
Sub FamilyComposition() '' Author: boa '' Written: 05.07.2018 ' Description: формирует таблицу "состав семьи" Dim NewMyArray, MyArray Dim Rng As Range, a As Range Dim MyKey$, i&, iRow& Dim R1, R2, KeysArray(), ItemsArray() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("Посетители").Range("Т1[#All]") On Error Resume Next For Each a In Rng.Rows If Year(Date - CDate(a.Cells(3).Value)) - 1900 < 18 Then 'выбирает только тех кому нет 18 лет MyKey = a.Cells(10).Value & "|" & a.Cells(11).Value & "|" & a.Cells(12).Value If Dic.Exists(MyKey) Then Dic.Item(MyKey) = Dic.Item(MyKey) & "|" & a.Cells(2).Value Else Dic.Add MyKey, a.Cells(2).Value End If End If Next a KeysArray = Dic.Keys ItemsArray = Dic.Items With Application: .ScreenUpdating = False: .EnableEvents = False With Sheets("Семьи") 'лист, на который выгружаются данные .Cells.Clear 'очищаем старые значения For i = LBound(KeysArray) To UBound(KeysArray) iRow = iRow + 1 R1 = Split(KeysArray(i), "|") R2 = Split(ItemsArray(i), "|") .Cells(iRow, 1) = IIf(i = 0, UBound(KeysArray), i) 'номер семьи .Range(.Cells(iRow, 2), .Cells(iRow, 4)) = R1 'родители, адрес .Range(.Cells(iRow + 1, 2), .Cells(iRow + UBound(R2) + 1, 2)) = Application.Transpose(R2) 'дети With .Range(.Cells(iRow, 1), .Cells(iRow, 4)) .Interior.Color = vbBlack 'цвет заливки .Font.Color = vbWhite 'цвет шрифта End With iRow = iRow + UBound(R2) + 2 ' если не желаете, что бы между семьями добавлялась пустая строка - замените 2 на 1 Next .Select End With .ScreenUpdating = True: .EnableEvents = True: End With End Sub
Спасибо за Ваш труд. Всё отлично. Подскажите, что и где в макросе нужно сделать чтобы на листе Семьи в строке 2 не писалось Фамилия И.О(и вообще этой строки не было). И в колонках Отец и Мать если таковых нет то должно писаться Нет
Спасибо за Ваш труд. Всё отлично. Подскажите, что и где в макросе нужно сделать чтобы на листе Семьи в строке 2 не писалось Фамилия И.О(и вообще этой строки не было). И в колонках Отец и Мать если таковых нет то должно писаться НетDrMini
Сообщение отредактировал DrMini - Четверг, 05.07.2018, 19:46
Sub FamilyComposition() '' Author: boa '' Written: 05.07.2018 ' Description: формирует таблицу "состав семьи" Dim NewMyArray, MyArray Dim Rng As Range, a As Range Dim MyKey$, i&, iRow& Dim R1, R2, KeysArray(), ItemsArray() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("Посетители").Range("Т1[#All]") On Error Resume Next For Each a In Rng.Rows If Year(Date - CDate(a.Cells(3).Value)) - 1900 < 18 Then 'выбирает только тех кому нет 18 лет MyKey = IIf(a.Cells(10).Value = "", "Нет", a.Cells(10).Value) & "|" & _ IIf(a.Cells(11).Value = "", "Нет", a.Cells(11).Value) & "|" & _ IIf(a.Cells(12).Value = "", "Нет", a.Cells(12).Value) If Dic.Exists(MyKey) Then Dic.Item(MyKey) = Dic.Item(MyKey) & "|" & a.Cells(2).Value Else Dic.Add MyKey, a.Cells(2).Value End If End If Next a KeysArray = Dic.Keys ItemsArray = Dic.Items With Application: .ScreenUpdating = False: .EnableEvents = False With Sheets("Семьи") 'лист, на который выгружаются данные .Cells.Clear 'очищаем старые значения For i = LBound(KeysArray) To UBound(KeysArray) iRow = iRow + 1 With .Range(.Cells(iRow, 1), .Cells(iRow, 4)) If i = 0 Then .Interior.Color = 16776960 .Font.Bold = True .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireRow.RowHeight = 30 Else .Interior.Color = vbBlack 'цвет заливки .Font.Color = vbWhite 'цвет шрифта End If End With R1 = Split(KeysArray(i), "|") R2 = Split(ItemsArray(i), "|") .Cells(iRow, 1) = IIf(i = 0, UBound(KeysArray), i) 'номер семьи .Range(.Cells(iRow, 2), .Cells(iRow, 4)) = R1 'родители, адрес .Range(.Cells(iRow + 1, 2), .Cells(iRow + UBound(R2) + 1, 2)) = Application.Transpose(R2) 'дети If i > 0 Then iRow = iRow + UBound(R2) + 1 ' если желаете, что бы между семьями добавлялась пустая строка - замените 1 на 2 Next .Columns(1).HorizontalAlignment = xlCenter .Select End With .ScreenUpdating = True: .EnableEvents = True: End With End Sub
[/vba]
DrMini, подправил
[vba]
Код
Option Explicit
Sub FamilyComposition() '' Author: boa '' Written: 05.07.2018 ' Description: формирует таблицу "состав семьи" Dim NewMyArray, MyArray Dim Rng As Range, a As Range Dim MyKey$, i&, iRow& Dim R1, R2, KeysArray(), ItemsArray() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("Посетители").Range("Т1[#All]") On Error Resume Next For Each a In Rng.Rows If Year(Date - CDate(a.Cells(3).Value)) - 1900 < 18 Then 'выбирает только тех кому нет 18 лет MyKey = IIf(a.Cells(10).Value = "", "Нет", a.Cells(10).Value) & "|" & _ IIf(a.Cells(11).Value = "", "Нет", a.Cells(11).Value) & "|" & _ IIf(a.Cells(12).Value = "", "Нет", a.Cells(12).Value) If Dic.Exists(MyKey) Then Dic.Item(MyKey) = Dic.Item(MyKey) & "|" & a.Cells(2).Value Else Dic.Add MyKey, a.Cells(2).Value End If End If Next a KeysArray = Dic.Keys ItemsArray = Dic.Items With Application: .ScreenUpdating = False: .EnableEvents = False With Sheets("Семьи") 'лист, на который выгружаются данные .Cells.Clear 'очищаем старые значения For i = LBound(KeysArray) To UBound(KeysArray) iRow = iRow + 1 With .Range(.Cells(iRow, 1), .Cells(iRow, 4)) If i = 0 Then .Interior.Color = 16776960 .Font.Bold = True .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireRow.RowHeight = 30 Else .Interior.Color = vbBlack 'цвет заливки .Font.Color = vbWhite 'цвет шрифта End If End With R1 = Split(KeysArray(i), "|") R2 = Split(ItemsArray(i), "|") .Cells(iRow, 1) = IIf(i = 0, UBound(KeysArray), i) 'номер семьи .Range(.Cells(iRow, 2), .Cells(iRow, 4)) = R1 'родители, адрес .Range(.Cells(iRow + 1, 2), .Cells(iRow + UBound(R2) + 1, 2)) = Application.Transpose(R2) 'дети If i > 0 Then iRow = iRow + UBound(R2) + 1 ' если желаете, что бы между семьями добавлялась пустая строка - замените 1 на 2 Next .Columns(1).HorizontalAlignment = xlCenter .Select End With .ScreenUpdating = True: .EnableEvents = True: End With End Sub
Именно то, что надо. Низкий поклон и боoooльшущее спасибо! Если у Вас найдётся время то добавьте пожалуйста в макрос создание границы в заполненных ячейках на листе Семья. Не критично но смотрится и читается таблица намного лучше.
Именно то, что надо. Низкий поклон и боoooльшущее спасибо! Если у Вас найдётся время то добавьте пожалуйста в макрос создание границы в заполненных ячейках на листе Семья. Не критично но смотрится и читается таблица намного лучше.DrMini
Сообщение отредактировал DrMini - Четверг, 05.07.2018, 21:03
DrMini, Такие мелочи, как границы, могли бы попробовать и макрорекодером записать и потом подставить в код
[vba]
Код
Option Explicit
Sub FamilyComposition() '' Author: boa '' Written: 05.07.2018 ' Description: формирует таблицу "состав семьи" Dim NewMyArray, MyArray Dim Rng As Range, a As Range Dim MyKey$, i&, iRow& Dim R1, R2, KeysArray(), ItemsArray() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("Посетители").Range("Т1[#All]") On Error Resume Next For Each a In Rng.Rows If Year(Date - CDate(a.Cells(3).Value)) - 1900 < 18 Then 'выбирает только тех кому нет 18 лет MyKey = IIf(a.Cells(10).Value = "", "Нет", a.Cells(10).Value) & "|" & _ IIf(a.Cells(11).Value = "", "Нет", a.Cells(11).Value) & "|" & _ IIf(a.Cells(12).Value = "", "Нет", a.Cells(12).Value) If Dic.Exists(MyKey) Then Dic.Item(MyKey) = Dic.Item(MyKey) & "|" & a.Cells(2).Value Else Dic.Add MyKey, a.Cells(2).Value End If End If Next a KeysArray = Dic.Keys ItemsArray = Dic.Items With Application: .ScreenUpdating = False: .EnableEvents = False With Sheets("Семьи") 'лист, на который выгружаются данные .Cells.Clear 'очищаем старые значения For i = LBound(KeysArray) To UBound(KeysArray) iRow = iRow + 1 With .Range(.Cells(iRow, 1), .Cells(iRow, 4)) If i = 0 Then .Interior.Color = 16776960 .Font.Bold = True .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireRow.RowHeight = 30 Else .Interior.Color = vbBlack 'цвет заливки .Font.Color = vbWhite 'цвет шрифта '------------------------добавлено форматирование----------------------------------------------- .Borders(xlInsideVertical).Color = vbWhite '----------------------------------------------------------------------------------------------- End If End With R1 = Split(KeysArray(i), "|") R2 = Split(ItemsArray(i), "|") .Cells(iRow, 1) = IIf(i = 0, UBound(KeysArray), i) 'номер семьи .Range(.Cells(iRow, 2), .Cells(iRow, 4)) = R1 'родители, адрес .Range(.Cells(iRow + 1, 2), .Cells(iRow + UBound(R2) + 1, 2)) = Application.Transpose(R2) 'дети '------------------------добавлено форматирование----------------------------------------------- With .Range(.Cells(iRow + 1, 1), .Cells(iRow + UBound(R2) + 1, 4)) '.LineStyle = xlContinuous: .Color = vbBlack: 'можно да же не указывать. Excel возьмет значения по умолчанию With .Borders(xlEdgeLeft): .LineStyle = xlContinuous: .Color = vbBlack: .Weight = xlMedium: End With .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlInsideHorizontal).Weight = xlThin End With '----------------------------------------------------------------------------------------------- If i > 0 Then iRow = iRow + UBound(R2) + 1 ' если желаете, что бы между семьями добавлялась пустая строка - замените 1 на 2 Next .Columns(1).HorizontalAlignment = xlCenter .Select End With .ScreenUpdating = True: .EnableEvents = True: End With End Sub
[/vba]
DrMini, Такие мелочи, как границы, могли бы попробовать и макрорекодером записать и потом подставить в код
[vba]
Код
Option Explicit
Sub FamilyComposition() '' Author: boa '' Written: 05.07.2018 ' Description: формирует таблицу "состав семьи" Dim NewMyArray, MyArray Dim Rng As Range, a As Range Dim MyKey$, i&, iRow& Dim R1, R2, KeysArray(), ItemsArray() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("Посетители").Range("Т1[#All]") On Error Resume Next For Each a In Rng.Rows If Year(Date - CDate(a.Cells(3).Value)) - 1900 < 18 Then 'выбирает только тех кому нет 18 лет MyKey = IIf(a.Cells(10).Value = "", "Нет", a.Cells(10).Value) & "|" & _ IIf(a.Cells(11).Value = "", "Нет", a.Cells(11).Value) & "|" & _ IIf(a.Cells(12).Value = "", "Нет", a.Cells(12).Value) If Dic.Exists(MyKey) Then Dic.Item(MyKey) = Dic.Item(MyKey) & "|" & a.Cells(2).Value Else Dic.Add MyKey, a.Cells(2).Value End If End If Next a KeysArray = Dic.Keys ItemsArray = Dic.Items With Application: .ScreenUpdating = False: .EnableEvents = False With Sheets("Семьи") 'лист, на который выгружаются данные .Cells.Clear 'очищаем старые значения For i = LBound(KeysArray) To UBound(KeysArray) iRow = iRow + 1 With .Range(.Cells(iRow, 1), .Cells(iRow, 4)) If i = 0 Then .Interior.Color = 16776960 .Font.Bold = True .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireRow.RowHeight = 30 Else .Interior.Color = vbBlack 'цвет заливки .Font.Color = vbWhite 'цвет шрифта '------------------------добавлено форматирование----------------------------------------------- .Borders(xlInsideVertical).Color = vbWhite '----------------------------------------------------------------------------------------------- End If End With R1 = Split(KeysArray(i), "|") R2 = Split(ItemsArray(i), "|") .Cells(iRow, 1) = IIf(i = 0, UBound(KeysArray), i) 'номер семьи .Range(.Cells(iRow, 2), .Cells(iRow, 4)) = R1 'родители, адрес .Range(.Cells(iRow + 1, 2), .Cells(iRow + UBound(R2) + 1, 2)) = Application.Transpose(R2) 'дети '------------------------добавлено форматирование----------------------------------------------- With .Range(.Cells(iRow + 1, 1), .Cells(iRow + UBound(R2) + 1, 4)) '.LineStyle = xlContinuous: .Color = vbBlack: 'можно да же не указывать. Excel возьмет значения по умолчанию With .Borders(xlEdgeLeft): .LineStyle = xlContinuous: .Color = vbBlack: .Weight = xlMedium: End With .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlInsideHorizontal).Weight = xlThin End With '----------------------------------------------------------------------------------------------- If i > 0 Then iRow = iRow + UBound(R2) + 1 ' если желаете, что бы между семьями добавлялась пустая строка - замените 1 на 2 Next .Columns(1).HorizontalAlignment = xlCenter .Select End With .ScreenUpdating = True: .EnableEvents = True: End With End Sub
Такие мелочи, как границы, могли бы попробовать и макрорекодером записать и потом подставить в код
Это явно не моё. В формулах разбираться интересно. Кое, что понимаю. Но вот в VBA вааще НОЛЬ. Даже не затягивает. Могу часами настраивать MikroTik, собирать и настраивать компьютеры но макросы явно не моё. Спасибо Вам за помощь. Очень помогли.
Такие мелочи, как границы, могли бы попробовать и макрорекодером записать и потом подставить в код
Это явно не моё. В формулах разбираться интересно. Кое, что понимаю. Но вот в VBA вааще НОЛЬ. Даже не затягивает. Могу часами настраивать MikroTik, собирать и настраивать компьютеры но макросы явно не моё. Спасибо Вам за помощь. Очень помогли.DrMini