Выбор данных по условию с сортировкой

Дата: Среда, 14.03.2018, 08:20 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 109

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Доброе утро всем!
Не знаю возможно ли это сделать, но постараюсь объяснить.
Подскажите как макросом выбрать данные из таблицы по такому принципу
В столбцах А В С есть номера актов, в столбце Е название работ, в N Q T дата их выполнения
Как выбрать данные в два столбца на новом листе, только там где есть номер акта, таким образом
если в А есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в А от дата из N)
если в B есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в B от дата из Q)
если в C есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в C от дата из T)
и все это посортировать по номеру акта.
На листе Результат привел пример, как должно получиться.
Думаю, там более понятно, чем мое описание )))

К сообщению приложен файл: 0129018.xlsx (20.5 Kb)

sboy

Дата: Среда, 14.03.2018, 10:24 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

Добрый день.
[vba]

Код

Sub chevryachok()
Dim arr()
Application.ScreenUpdating = False
    For q = 1 To 3
        ilr = WorksheetFunction.Max(Cells(Rows.Count, q).End(xlUp).Row, ilr)
    Next
    qount = WorksheetFunction.Count(Range("A4:C" & ilr))
    ReDim arr(1 To qount, 1 To 3)
    i = 1
    For r = 4 To ilr
        For j = 1 To 3
            If Not IsEmpty(Cells(r, j)) Then
                arr(i, 1) = "АОСР (" & Cells(r, 5) & ")"
                arr(i, 2) = "№" & Cells(r, j) & " от " & Cells(r, j).Offset(0, 11 + 2 * j)
                arr(i, 3) = Cells(r, j)
                i = i + 1
            End If
        Next j
    Next r

    With Sheets(2)
        .Cells(1).CurrentRegion.Clear
        Set res = .Cells(1).Resize(qount, 3)
        res.Value = arr
            With .Sort
                .SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues
                .SetRange res
                .Header = xlGuess
                .Orientation = xlTopToBottom
                .Apply
            End With
        .Columns(3).Delete
        Application.ScreenUpdating = True
        .Activate
    End With
End Sub

[/vba]

К сообщению приложен файл: 0129018.xlsm (30.9 Kb)

Яндекс: 410016850021169

Сообщение отредактировал sboy - Среда, 14.03.2018, 10:37

Дата: Среда, 14.03.2018, 11:10 | Сообщение № 3

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2731

Репутация: 1132 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Тоже поучаствую. Составной оператор с использованием SQL и ADO для безпроцедурного исполнения в Окне отладки Редактора VB:
[vba]

Код

Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT 'АОСР (' & B & ')', '№ ' & A & ' от ' & C FROM ( " _
& "SELECT CLng(F1) AS A, F5 AS B, CDate(F14) AS C FROM ( " _
& "SELECT F1,F5,F14 FROM [Реестр$A4:T1000] WHERE F1 Is Not Null " _
& "UNION ALL SELECT F2,F5,F17 FROM [Реестр$A4:T1000] WHERE F2 Is Not Null " _
& "UNION ALL SELECT F3,F5,F20 FROM [Реестр$A4:T1000] WHERE F3 Is Not Null " _
& ") ORDER BY 1 )", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=No'": _
[Результат!A1].CopyFromRecordset rst

[/vba]
Копируете в Окно отладки, встаете в конец последней строки и жмете Enter.

МОИ: Ник, Tip box: 41001663842605

Дата: Среда, 14.03.2018, 13:22 | Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 109

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

sboy, Gustav,
Спасибо огромное! Все работает hands

Gustav, скажите, а такой способ к кнопочке можно привязать или только копированием в окно?

Дата: Среда, 14.03.2018, 13:58 | Сообщение № 5

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2731

Репутация: 1132 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Цитата CHEVRYACHOK, 14.03.2018 в 13:22, в сообщении № 4 ()

такой способ к кнопочке можно привязать?

Конечно, можно. С минимальными усилиями будет примерно так:
[vba]

Код

Private Sub CommandButton1_Click()

Dim rst As Object

'и сюда вставляете вышеприведенный "моноблок" для Окна отладки
'................................................

End Sub

[/vba]

[p.s.]Чисто больше даже для себя в качестве узелка на память - еще один вариант "моноблока" - с одним вложенным SELECTом вместо двух, а также с эффективным использованием функций VBA внутри запроса: [/p.s.]

[vba]

Код

Set rst = CreateObject("ADODB.Recordset"): _
rst.Open "SELECT 'АОСР (' & F5 & ')', '№ ' & F1 & ' от ' & Format(F14, 'dd.mm.yyyy') FROM ( " _
& "SELECT F1,F5,F14 FROM [Реестр$A4:T1000] WHERE F1 Is Not Null UNION ALL " _
& "SELECT F2,F5,F17 FROM [Реестр$A4:T1000] WHERE F2 Is Not Null UNION ALL " _
& "SELECT F3,F5,F20 FROM [Реестр$A4:T1000] WHERE F3 Is Not Null " _
& ") ORDER BY CLng(F1)", _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0;HDR=No'": _
[Результат!A1].CopyFromRecordset rst

[/vba]

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Среда, 14.03.2018, 14:25

Дата: Среда, 14.03.2018, 14:27 | Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 109

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Gustav, еще раз благодарю!

Дата: Среда, 14.03.2018, 15:21 | Сообщение № 7

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2731

Репутация: 1132 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Не за что! Мне по кайфу дёргать данные Excel при помощи SQL

В догонку ещё один кейсик - процедура для кнопки без объявления переменной рекордсета (rst):
[vba]

Код

Private Sub CommandButton1_Click()

With CreateObject("ADODB.Recordset")
    .Open "SELECT 'АОСР (' & F5 & ')', '№ ' & F1 & ' от ' & Format(F14, 'dd.mm.yyyy') FROM ( " _
    & "SELECT F1,F5,F14 FROM [Реестр$A4:T1000] WHERE F1 Is Not Null UNION ALL " _
    & "SELECT F2,F5,F17 FROM [Реестр$A4:T1000] WHERE F2 Is Not Null UNION ALL " _
    & "SELECT F3,F5,F20 FROM [Реестр$A4:T1000] WHERE F3 Is Not Null " _
    & ") ORDER BY CLng(F1)", _
    "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
    & ThisWorkbook.FullName & _
    ";Extended Properties='Excel 12.0;HDR=No'"

    [Результат!A1].CopyFromRecordset .DataSource
End With

End Sub

[/vba]

МОИ: Ник, Tip box: 41001663842605

Дата: Среда, 14.03.2018, 16:47 | Сообщение № 8

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 109

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Gustav, все работает!!! Подскажите, а как будет выглядеть блок, если делать, только по первому столбцу без 2-го и 3-го?

Дата: Среда, 14.03.2018, 18:36 | Сообщение № 9

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2731

Репутация: 1132 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Цитата CHEVRYACHOK, 14.03.2018 в 16:47, в сообщении № 8 ()

как будет выглядеть блок, если

Давайте я покажу версию с Вашими заголовками полей (а не с безликими умолчательными F1-F20) и, думаю, всё более-менее прояснится:
[vba]

Код

Private Sub CommandButton1_Click()

With CreateObject("ADODB.Recordset")
    .Open "SELECT 'АОСР (' & [Наименование работ] & ')', '№ ' & [Номер акта] & ' от ' & Format([Дата акта], 'dd.mm.yyyy') FROM ( " _
    & "SELECT [Номер акта] ,[Наименование работ],[Дата акта]  FROM [Реестр$A3:T1000] WHERE [Номер акта]  Is Not Null UNION ALL " _
    & "SELECT [Номер акта1],[Наименование работ],[Дата акта1] FROM [Реестр$A3:T1000] WHERE [Номер акта1] Is Not Null UNION ALL " _
    & "SELECT [Номер акта2],[Наименование работ],[Дата акта2] FROM [Реестр$A3:T1000] WHERE [Номер акта2] Is Not Null " _
    & ") ORDER BY CLng([Номер акта])", _
    "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
    & ThisWorkbook.FullName & _
    ";Extended Properties='Excel 12.0;HDR=Yes'"

    [Результат!A1].CopyFromRecordset .DataSource
End With

End Sub

[/vba]
Обращаю внимание, что диапазон выборки теперь начинается со строки 3 (а не 4) и параметр HDR=Yes. А также на то, что общие заголовки полей внутреннего SELECT наследуются от первого SELECT из трёх, объединенных при помощи UNION.

[p.s.]Если же хотите делать выборку без 2-го и 3-го только по колонкам A, E и N, то запрос значительно упрощается: [/p.s.]

[vba]

Код

Private Sub CommandButton1_Click()

With CreateObject("ADODB.Recordset")
    .Open "SELECT 'АОСР (' & [Наименование работ] & ')', '№ ' & [Номер акта] & ' от ' & Format([Дата акта], 'dd.mm.yyyy') " _
    & "FROM [Реестр$A3:T1000] WHERE [Номер акта] Is Not Null ORDER BY CLng([Номер акта])", _
    "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
    & ThisWorkbook.FullName & _
    ";Extended Properties='Excel 12.0;HDR=Yes'"

    [Результат!A1].CopyFromRecordset .DataSource
End With

End Sub

[/vba]

Цитата CHEVRYACHOK, 14.03.2018 в 16:47, в сообщении № 8 ()

как будет выглядеть блок, если

Код

Private Sub CommandButton1_Click()

With CreateObject("ADODB.Recordset")
    .Open "SELECT 'АОСР (' & [Наименование работ] & ')', '№ ' & [Номер акта] & ' от ' & Format([Дата акта], 'dd.mm.yyyy') " _
    & "FROM [Реестр$A3:T1000] WHERE [Номер акта] Is Not Null ORDER BY CLng([Номер акта])", _
    "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
    & ThisWorkbook.FullName & _
    ";Extended Properties='Excel 12.0;HDR=Yes'"

    [Результат!A1].CopyFromRecordset .DataSource
End With

End Sub

[/vba]Gustav

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Среда, 14.03.2018, 18:57

Сообщение

Цитата CHEVRYACHOK, 14.03.2018 в 16:47, в сообщении № 8 ()

как будет выглядеть блок, если

Код

Private Sub CommandButton1_Click()

With CreateObject("ADODB.Recordset")
    .Open "SELECT 'АОСР (' & [Наименование работ] & ')', '№ ' & [Номер акта] & ' от ' & Format([Дата акта], 'dd.mm.yyyy') " _
    & "FROM [Реестр$A3:T1000] WHERE [Номер акта] Is Not Null ORDER BY CLng([Номер акта])", _
    "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
    & ThisWorkbook.FullName & _
    ";Extended Properties='Excel 12.0;HDR=Yes'"

    [Результат!A1].CopyFromRecordset .DataSource
End With

End Sub

[/vba]

Автор - Gustav
Дата добавления - 14.03.2018 в 18:36

Дата: Четверг, 15.03.2018, 07:46 | Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 109

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Gustav, спасибо! hands

Оч круто, попробую применить к другим вариантам