Доброе утро всем! Не знаю возможно ли это сделать, но постараюсь объяснить. Подскажите как макросом выбрать данные из таблицы по такому принципу В столбцах А В С есть номера актов, в столбце Е название работ, в N Q T дата их выполнения Как выбрать данные в два столбца на новом листе, только там где есть номер акта, таким образом если в А есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в А от дата из N) если в B есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в B от дата из Q) если в C есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в C от дата из T) и все это посортировать по номеру акта. На листе Результат привел пример, как должно получиться. Думаю, там более понятно, чем мое описание )))
Доброе утро всем! Не знаю возможно ли это сделать, но постараюсь объяснить. Подскажите как макросом выбрать данные из таблицы по такому принципу В столбцах А В С есть номера актов, в столбце Е название работ, в N Q T дата их выполнения Как выбрать данные в два столбца на новом листе, только там где есть номер акта, таким образом если в А есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в А от дата из N) если в B есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в B от дата из Q) если в C есть номер, то первый столбик - АОСР (название из столбца Е этой строки), второй - № (который в C от дата из T) и все это посортировать по номеру акта. На листе Результат привел пример, как должно получиться. Думаю, там более понятно, чем мое описание )))CHEVRYACHOK
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]
Добрый день. [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
Тоже поучаствую. Составной оператор с использованием 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.
Тоже поучаствую. Составной оператор с использованием 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.Gustav
Конечно, можно. С минимальными усилиями будет примерно так: [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]
Код
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
Не за что! Мне по кайфу дёргать данные 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]
Не за что! Мне по кайфу дёргать данные 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
Давайте я покажу версию с Вашими заголовками полей (а не с безликими умолчательными 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
Давайте я покажу версию с Вашими заголовками полей (а не с безликими умолчательными 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