Сбор данных из разных листов с автоматической сортировкой в алфавитном порядке

Пользователь

Сообщений: 52 Регистрация: 12.01.2016

12.02.2020 16:42:59

Доброго всем дня!
Подскажите пожалуйста, возможно ли при вводе информации на листах "а1", "а2", "а3" собирать автоматически общую информацию в листе "итог", сортируя строки в в алфавитном порядке и сохраняя формат таблицы?
Спасибо!

Прикрепленные файлы

Пример.xlsx (14.87 КБ)

Hugo Пользователь Сообщений: 23800 Регистрация: 22.12.2012	#2 12.02.2020 16:49:31 Теоретически можно. Макросом. Практически никто код писать не будет, ну разве что за почасовую оплату (время не нормировано...) А вот если убрать все объединения - дело сильно упрощается.

rudik Пользователь Сообщений: 52 Регистрация: 12.01.2016	#3 12.02.2020 17:29:25 Спасибо Hugo, все понятно

abc1 Пользователь Сообщений: 150 Регистрация: 02.03.2019	#4 12.02.2020 19:38:33 Неожиданно еле-собранный макрос на умной таблице не отработал Прикрепленные файлы Пример (66).xlsm (32.33 КБ)

Mershik

Пользователь

Сообщений: 8277 Регистрация: 03.12.2015

12.02.2020 20:36:31

rudik, ВАРИАНТ НО БЕЗ СОРТИРОВКИ И НЕ ИДЕАЛЬНО КАК У ВАС

Код

Sub Collector()

Dim i As Integer
Dim ilastrow As Integer
Dim r As Integer
Dim ws As Worksheet
Set ws = Worksheets("итог")
ws.Cells.Clear
For i = 1 To 3
    ilastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 4
    Worksheets(i).Range("A1").CurrentRegion.Copy Destination:=ws.Cells(ilastrow, 1)
Next i
ilastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Rows("1:4").Delete
'
    For i = ilastrow To 3 Step -1
    If Cells(i, 1) = "№ п/п" And Cells(i - 1, 1) = "" Then
    ws.Rows(i).Delete

    ws.Rows(i - 1).Delete
    ws.Rows(i - 2).Delete
    ws.Rows(1).Clear
    End If
    Next i

End Sub

Изменено: Mershik - 12.02.2020 21:22:56

Не бойтесь совершенства. Вам его не достичь.

rudik Пользователь Сообщений: 52 Регистрация: 12.01.2016	#6 13.02.2020 09:03:18 Mershik, спасибо за вариант, только второй цех не перенесен.

АналитикБУ Пользователь Сообщений: 36 Регистрация: 02.07.2019	#7 13.02.2020 09:07:46 rudik, посмотри в сторону Power Query. Функция "Объединить запросы". В PQ обработаешь, как требуется, а результат "Итог" выведешь в виде сводной таблицы. Останется только поиграть с представлением.

rudik Пользователь Сообщений: 52 Регистрация: 12.01.2016	#8 13.02.2020 09:41:05 АналитикБУ, Power Query - новая тема, базовых функций много не знаю, тем более когда сидишь на Офисе 2010, но дойду может быть. Спасибо!

abc1

Пользователь

Сообщений: 150 Регистрация: 02.03.2019

13.02.2020 11:13:31

Цитата
rudik написал: на Офисе 2010

Для Excel 2010 Power Query тоже есть

aequit

Пользователь

Сообщений: 209 Регистрация: 13.01.2020

#10

13.02.2020 11:26:17

rudik,
Вариант с сортировкой и вторым цехом:

Скрытый текст

Код

Option Explicit
Option Base 1
Public Sub Tabel()
'aequit 13.02.2020
Dim lastCol&, lLastRow&, i&, k&, l&, n&
Dim a(), fio$, tabn&
Dim oWS As Worksheet, oWS_Itog As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Set oWS_Itog = Worksheets("Итог")
oWS_Itog.Cells.Clear

For l = 1 To ThisWorkbook.Worksheets.Count - 1
    Set oWS = Worksheets(l)
    
    lastCol = oWS.Cells(2, oWS.Columns.Count).End(xlToLeft).Column
    lLastRow = oWS.Cells(oWS.Rows.Count, 2).End(xlUp).Row + 3
    
    ReDim a(lLastRow - 2, lastCol - 1)
    
    For i = 3 To lLastRow
        If oWS.Cells(i, 2) <> Empty Then
            fio$ = oWS.Cells(i, 2)
            tabn& = oWS.Cells(i, 3)
        End If
        a(i - 2, 1) = fio$
        a(i - 2, 2) = tabn&
        For k = 3 To lastCol - 1
            a(i - 2, k) = oWS.Cells(i, k + 1)
        Next k
    Next i

    lLastRow = oWS_Itog.Cells(Rows.Count, 2).End(xlUp).Row
    If lLastRow = 1 Then lLastRow = 0
    For i = 1 To UBound(a)
        oWS_Itog.Cells(i + lLastRow, 2) = a(i, 1)
        oWS_Itog.Cells(i + lLastRow, 3) = a(i, 2)
        For k = 4 To UBound(a, 2)
            oWS_Itog.Cells(i + lLastRow, k) = a(i, k - 1)
        Next k
    Next i
Next l

k = oWS_Itog.[B1].CurrentRegion.Columns.Count
l = oWS_Itog.[B1].CurrentRegion.Rows.Count
oWS_Itog.[B1].CurrentRegion.Sort oWS_Itog.[B1], xlAscending, Header:=xlNo

For i = 1 To l Step 4
    n = n + 1
    oWS_Itog.Cells(i, 1) = n
    oWS_Itog.Range(oWS_Itog.Cells(i, 1), oWS_Itog.Cells(i + 3, 1)).MergeCells = True
    oWS_Itog.Range(oWS_Itog.Cells(i, 2), oWS_Itog.Cells(i + 3, 2)).MergeCells = True
    oWS_Itog.Range(oWS_Itog.Cells(i, 3), oWS_Itog.Cells(i + 3, 3)).MergeCells = True
Next i

oWS_Itog.Rows(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

oWS_Itog.[a1] = "№" & Chr(10) & "п/п"
oWS_Itog.[B1] = "Ф. И. О."
oWS_Itog.[C1] = "таб. №"

With oWS_Itog.[B1].CurrentRegion
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Borders.LineStyle = True
End With

oWS_Itog.Range(oWS_Itog.Cells(2, 2), oWS_Itog.Cells(l + 1, 2)).HorizontalAlignment = xlLeft

For i = 4 To k + 1
    oWS_Itog.Cells(1, i) = "час."
Next i
oWS_Itog.Columns("A:A").EntireColumn.AutoFit
oWS_Itog.Columns("B:B").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Прикрепленные файлы

Пример (6).xlsm (25.49 КБ)

rudik Пользователь Сообщений: 52 Регистрация: 12.01.2016	#11 13.02.2020 14:20:22 aequit, Отличный вариант, спасибо Вам!

aequit Пользователь Сообщений: 209 Регистрация: 13.01.2020	#12 13.02.2020 14:28:34 rudik, пожалуйста. Запомните простую истину: объединенные ячейки есть большое зло, не применяйте их никогда без очень большой необходимости.