как это сделать? как полностью нужно оформить? Заранее спасибо. Любое подключение для офиса 2016 -2021 но через SQL и одним запросом для выгрузки в один массив.
хочу создать подключение через SQL, к листу формы https://ibb.co/yVP5g54 так как лист имеет многострочную шапку, названия колонок не в 1 строке, а считывается с 1 строки, хочу обратиться через SQL по номерам колонок для считывания с указанной строки до последней заполненной ячейки листа цель - уйти от одномерных массивов на каждую колонку, а сразу выбрать все нужные колонки листа в один массив
Код
[IMG]https://ibb.co/yVP5g54[/IMG]
'создаем строку запроса
For li = LBound(avSheets) To UBound(avSheets)
sQuery = "SELECT " & "SELECT COL_NAME(OBJECT_ID(" & avSheets(li) & " ), 1)" & " FROM [" & avSheets(li) & "$]"
Next li
'сначала создаем подключение к временному файлу
'это поможет избежать ошибок подключения к открытому файлу
sCon = _
"ODBC;DSN=Excel Files;DBQ=" & sTmpFileName & ";" & _
"DefaultDir=" & sPath & ";DriverId=790;" & _
"MaxBufferSize=2048;PageTimeout=5"
Set oPTCache = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)
With oPTCache
.Connection = sCon
.CommandType = xlCmdSql
.CommandText = sQuery
Set oPT = .CreatePivotTable(rRes(3, 1))
End With
нужно выбрать столбец в ранг начиная с определенной строки
этот код
Код
Set rg = ThisWorkbook.Sheets(Element).UsedRange.Columns(1)
выбирает весь столбец по номеру, но как выбрать именно столбец начиная с определенной строки и до конца листа, чтобы не выбирать мусор, который идёт до нужных данных
условия задачи - построить интерактивный отчет - дашборд, С ИНТЕРАКТИВНОЙ КАРТОЙ, но на основании 3 лет помесячной статистики И ТЕМПОВ ПРИРОСТА, которая заключена в отдельных файлах с многоуровневыми заголовками (до 7 уровней) по 3 разным шаблонам с разным количеством столбцов, поэтому сводная не работает..
Вопрос был "КАК ПРАВИЛЬНО Вывести текстовый одномерный массив на лист,"
нужно с других листов книги (их много) собрать только выделенные столбцы. ВЕСЬ КОД ПРИВЕДЕН. Сводная не работает, так как все листы имеют многоуровневые шапки (до 7 уровней), и оформлены по 4 разным шаблонам (т.е. разное количество столбцов) https://ibb.co/yVP5g54
Добрый день! есть код нужно с других листов книги (их много) собрать тролько выделенные столбцы
Сводная не работает, так как все листы имеют многоуровневые шапки (до 7 уровней), и оформлены по 4 разным шаблонам (т.е. разное количество столбцов) https://ibb.co/yVP5g54
ПРОБЛЕМА массив IndeksArray на лист выводится (СТРОКА 1/139) , а массив DataArray1 текстовый - нет, а просто впечатывает последнее значение во все ячейки диапазона (СТРОКА 4/143) , если выводить как массив IndeksArray - то впечатывает только первое значение во все ячейки диапазона (СТРОКА 2/141), хотя в отладчике видно что массив содержит и другие значения. В чем проблема? как исправить?
Код
Sheets("настройка_отчета").Range("d9:d" & UBound(IndeksArray) + 9).Value = IndeksArray
' Sheets("настройка_отчета").Range("C9:C" & UBound(IndeksArray) + 9).Value = DataArray1
For Counter = 1 To UBound(DataArray1)
Sheets("настройка_отчета").Range("C9:C" & [Counter] + 9).Value = CVar(DataArray1(Counter))
Next Counter
Код
Function CombineArrays(Arr1 As Variant, Arr2 As Variant) As Variant
If (Not IsArray(Arr1)) And IsArray(Arr2) Then CombineArrays = Arr2: Exit Function
If (Not IsArray(Arr2)) And IsArray(Arr1) Then CombineArrays = Arr1: Exit Function
If (Not IsArray(Arr2)) And (Not IsArray(Arr1)) Then
Debug.Print "??????: ??? ?????????? ???????? ?? ???????? ?????????!"
CombineArrays = Null: Exit Function
End If
On Error Resume Next: Err.Clear
If (LBound(Arr1, 2) <> LBound(Arr2, 2)) Or (UBound(Arr1, 2) <> UBound(Arr2, 2)) Then
Debug.Print "??????: ??????????? ???????? (?? ??????) ?? ?????????"
CombineArrays = Null: Exit Function
End If
If Err.Number = 9 Then
Debug.Print "??????: ???? ?? ???????? ?? ???????? ?????????!"
CombineArrays = Null: Exit Function
End If
ReDim arr(1 To UBound(Arr1, 1) + UBound(Arr2, 1), LBound(Arr1, 2) To UBound(Arr1, 2))
For i = 1 To UBound(Arr1, 1)
For j = LBound(Arr1, 2) To UBound(Arr1, 2)
arr(i, j) = Arr1(i, j)
Next
Next
For i = 1 To UBound(Arr2, 1)
For j = LBound(Arr2, 2) To UBound(Arr2, 2)
arr(i + UBound(Arr1, 1), j) = Arr2(i, j)
Next
Next
CombineArrays = arr ' ?????????? ???????????? ??????
End Function
Function CombineArrays2(Arr1 As Variant, Arr2 As Variant) As Variant
If (Not IsArray(Arr1)) And IsArray(Arr2) Then CombineArrays2 = Arr2: Exit Function
If (Not IsArray(Arr2)) And IsArray(Arr1) Then CombineArrays2 = Arr1: Exit Function
' если оба параметра функции не являются массивами
If (Not IsArray(Arr2)) And (Not IsArray(Arr1)) Then
Debug.Print "ОШИБКА: Оба переданных значения не являются массивами!"
CombineArrays2 = Null: Exit Function
End If
' проверяем совпадение размерностей массивов Arr1 и Arr2
On Error Resume Next: Err.Clear
ReDim arr(1 To UBound(Arr1) + UBound(Arr2))
For i = 1 To UBound(Arr1, 1)
arr(i) = Arr1(i)
Next
For i = 1 To UBound(Arr2, 1)
arr(i + UBound(Arr1)) = Arr2(i)
Next
CombineArrays2 = arr ' возвращаем объединённый массив
End Function
Sub CreateTableM()
Dim arrRecords() As Variant
Dim aa As Variant
Dim Element As Variant
Dim rg As Range
Dim rg2 As Range
Dim rg3 As Range
Dim objRange As Range
Dim IndeksArray As Variant
Dim DataArray1 As Variant
Dim DataArray2 As Variant
Dim k As Integer
Dim ttt As Integer
Dim cl As New Collection, x
k = 0
Dim arrWsNames
arrWsNames = Array("Жовтень2021", "Жовтень2020", "Жовтень2019")
ttt = 1
ReDim DataArray2(ttt)
ReDim DataArray1(ttt)
For Each Element In arrWsNames
With Line
ttt = SLastRow(Element)
Set rg = ThisWorkbook.Sheets(Element).UsedRange.Columns(1)
Set rg2 = ThisWorkbook.Sheets(Element).UsedRange.Columns(27)
ttt = UBound(ThisWorkbook.Sheets(Element).UsedRange.Columns(1).Value)
ReDim DataArray2(ttt)
For i = 1 To ttt
DataArray2(i) = Element
Next i
Set objRange = Union(rg, rg2)
ОбъединённыйМассив12 = CombineArrays(IndeksArray, objRange)
IndeksArray = ОбъединённыйМассив12
ОбъединённыйМассив11 = CombineArrays2(DataArray1, DataArray2)
DataArray1 = ОбъединённыйМассив11
If SLastCol(Element) = 75 Then
' aa = rF.Value2
ElseIf SLastCol(Element) = 80 Then
' aa = rF.Value2
ElseIf SLastCol(Element) = 89 Then
' aa = rF.Value2
End If
k = SLastRow(Element)
End With
Next
'обїединение одномерных массивов в многомерный
ReDim Preserve arrRecords(1 To ttt, 1 To 42)
Sheets("настройка_отчета").Range("d9:d" & UBound(IndeksArray) + 9).Value = IndeksArray
' Sheets("настройка_отчета").Range("C9:C" & UBound(IndeksArray) + 9).Value = DataArray1
For Counter = 1 To UBound(DataArray1)
Sheets("настройка_отчета").Range("C9:C" & [Counter] + 9).Value = CVar(DataArray1(Counter))
Next Counter
End Sub
Добрый день! Хочу сделать свою интерактивную карту - график в Excel 2016 , с управлением заливкой сгруппированных частей карты. Вставляю рисунки с прозрачным фоном через вставка/рисунки/это устройство. Проблема -
Код
.Fill.ForeColor.RGB = vbYellow
заливает квадратные границы рисунка - т.е. прозрачный фон, а не фон самого рисунка, т.е. VBA не видит узлы рисунка, в то время как на примере карты каждая часть карты отображается именно узлами и заливка происходи внутри узлов рисунка - Вопрос "как реализовать заливку внутри узлов рисунка"
Код
Dim list As Worksheet
Dim NorthAmerica As Shape
Dim SouthAmerica As Shape
Dim Europe As Shape
Dim Asia As Shape
Dim Africa As Shape
Dim Australia As Shape
Dim tovar1 As Long
Dim tovar2 As Long
Dim tovar3 As Long
tovar1 = Range("B1").Interior.Color
tovar2 = Range("C1").Interior.Color
tovar3 = Range("D1").Interior.Color
Dim a() As Variant
a = Array(tovar1, tovar2, tovar3)
Set list = Sheets("ВИЗУАЛИЗАЦИЯ")
Set Kodumska_ob = list.Shapes("Kodumska")
With Kodumska_ob
'?????? ?????? ? ?????? ??????
.Height = 150
.Width = 100
'?????? ???? ??????
.Fill.ForeColor.RGB = vbYellow
'???????????? ?????? ????? ?? 40 ????????
.Rotation = -40
End With
на рисунке 2 результата с "нужный вариант" - как должно быть - выделенные узлы части рисунка и заливка внутри с "получаемый" - как получается VBA не видит узлов рисунка и заливает фон всего квадрата
как достичь "нужного варианта" - заменить всё автофигурами не получается, так как все автофигуры в Excel имеют стандартный перечень форм, а формы областей карты региона - не стандартные и должны состоять из большого множества узлов. рисунок вопроса
Добрый День! Прошу помощи, давно не пользовалась excelem нужно передать массив названия листов в процедуру формирующую сводную по нескольким листам. Ошибка "Драйвер ODBC Excel] Ошибочная инструкция SQL предполагалось " в строке Set oPT = .CreatePivotTable(rRes(3, 1))
Код
Option Explicit
Public Function SheetList() As String()
Dim sheet As Worksheet
Dim n As Integer
Dim i As Integer
Dim arr() As String
Dim cell As Range
i = 1
n = 0
With ActiveWorkbook
For Each sheet In ActiveWorkbook.Worksheets
'Set cell = Worksheets(1).Cells(sheet.Index, 1)
'MsgBox (sheet.Name)
If ((sheet.Name <> "Ñïðàâî÷íèê") And (sheet.Name <> "îò÷åò") And (sheet.Name <> "Ñâîä")) Then
n = n + 1
End If
Next
End With
ReDim arr(1 To n)
With ActiveWorkbook
For Each sheet In ActiveWorkbook.Worksheets
Set cell = Worksheets(1).Cells(sheet.Index, 1)
'cell.Formula = sheet.Name
'MsgBox (sheet.Name)
If ((sheet.Name <> "Ñïðàâî÷íèê") And (sheet.Name <> "îò÷åò") And (sheet.Name <> "Ñâîä")) Then
arr(i) = sheet.Name
i = i + 1
End If
Next
End With
SheetList = arr()
End Function
Sub PTFromMultipleSheets()
Dim oPTCache As PivotCache, oPT As PivotTable
Dim sPath As String, sWbFulName As String, sTmpFileName As String
Dim avSheets() As String
Dim sCols As String, sQuery As String, sCon As String
Dim rRes As Range
Dim li As Long
sPath = ThisWorkbook.Path
sWbFulName = ThisWorkbook.FullName
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sTmpFileName = sPath & "TempWbForDB_" & Format(Now, "yyyymmddhhmmss") & ".xls"
'ñþäà ìîæíî äîáàâèòü åùå ëèñòû
'òàáëèöû íà ëèñòàõ äîëæíû èìåòü îäèíàêîâîå êîë-âî ñòîëáöîâ
'ñòîëáöû ìîãóò áûòü â ðàçíîì ïîðÿäêå, íî èìåòü îäèíàêîâûå çàãîëîâêè
avSheets = SheetList()
'íèæå ïåðå÷èñëÿþòñÿ çàãîëîâêè ñòîëáöîâ, íà îñíîâå êîòîðûõ ñòðîèòñÿ ñâîäíàÿ
'÷åðåç çàïÿòóþ â êâàäðàòíûõ ñêîáêàõ
sCols = "[Îáúåêò],[Êîíòðàãåíò],[ÑóììàÄîêóìåíòà]"
'sCols = "*" ' - åñëè íåîáõîäèìî âêëþ÷èòü âñå ñòîëáöû
'ïðè ýòîì øàïêà íà âñåõ ëèñòàõ äîëæíà áûòü ïîëíîñòüþ îäèíàêîâàÿ
'äàííûå áóäóò â òîì ïîðÿäêå, â êîòîðîì ðàñïîëîæåíû ñòîëáöû
Application.ScreenUpdating = False
If Val(Application.Version) > 11 Then DelCon
Set rRes = ThisWorkbook.Sheets(1).Cells
rRes.Clear
ThisWorkbook.Worksheets(avSheets).Copy
With ActiveWorkbook
.SaveAs sTmpFileName
.Close
End With
'ñîçäàåì ñòðîêó çàïðîñà
For li = LBound(avSheets) To UBound(avSheets)
If li > 0 Then
sQuery = sQuery & " UNION SELECT " & sCols & " FROM [" & avSheets(li) & "$]"
Else
sQuery = "SELECT " & sCols & " FROM [" & avSheets(li) & "$]"
End If
Next li
'ñíà÷àëà ñîçäàåì ïîäêëþ÷åíèå ê âðåìåííîìó ôàéëó
'ýòî ïîìîæåò èçáåæàòü îøèáîê ïîäêëþ÷åíèÿ ê îòêðûòîìó ôàéëó
sCon = _
"ODBC;DSN=Excel Files;DBQ=" & sTmpFileName & ";" & _
"DefaultDir=" & sPath & ";DriverId=790;" & _
"MaxBufferSize=2048;PageTimeout=5"
Set oPTCache = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)
With oPTCache
.Connection = sCon
.CommandType = xlCmdSql
.CommandText = sQuery
Set oPT = .CreatePivotTable(rRes(3, 1))
End With
'òåïåðü èçìåíÿåì â çàïðîñå ñâîäíîé ïóòü ê ôàéëó íà òåêóùèé
sCon = _
"ODBC;DSN=Excel Files;DBQ=" & sWbFulName & ";" & _
"DefaultDir=" & sPath & ";DriverId=790;" & _
"MaxBufferSize=2048;PageTimeout=5"
ThisWorkbook.PivotCaches(1).Connection = sCon
With oPT
'âûñòàâëÿåì ïåðâîíà÷àëüíûå íàñòðîéêè äëÿ ñâîäíîé
With .PivotFields(1)
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields(2)
.Orientation = xlRowField
.Position = 2
End With
.AddDataField .PivotFields("Ñóììà"), "Ñóììà ïî ïîëþ Ñóììà", xlSum
End With
'óäàëÿåì âðåìåííûé ôàéë
Kill sTmpFileName
Set oPT = Nothing: Set oPTCache = Nothing
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DelCon
' Purpose : Ïðîöåäóðà óäàëÿåò ïîäêëþ÷åíèÿ
' Òðåáóåòñÿ òîëüêî äëÿ âåðñèé, âûøå 2003
'---------------------------------------------------------------------------------------
Private Sub DelCon()
On Error Resume Next: ThisWorkbook.Connections(1).Delete: On Error GoTo 0
End Sub
Sub RefreshCon()
Dim sCon As String, sPath As String, sWbFulName As String
sPath = ThisWorkbook.Path
sWbFulName = ThisWorkbook.FullName
sCon = _
"ODBC;DSN=Excel Files;DBQ=" & sWbFulName & ";" & _
"DefaultDir=" & sPath & ";DriverId=790;" & _
"MaxBufferSize=2048;PageTimeout=5"
With ThisWorkbook
If .PivotCaches.Count > 0 Then .PivotCaches(1).Connection = sCon
End With
End Sub
Добрый День! Подскажите, пожалуйста, кто-то проверял достоверность прогнозов создаваемых с помощью инструмента "Лист прогноза"? Кто знает как добиться достоверности прогноза (конкретные действия) или примеры использования другого функционала в Excel? или у кого-то есть примеры макросов по прогнозированию? прогноз продаж...нужно чтобы как можно ближе было к факту...Заранее большое спасибо.
JeyCi, если честно то задание не менялось общее задание было описано в теме http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=45582&PAGEN_1=3 сообщение 73. Поменялась только общая концепция методов решения. Просто на 300 000 строк большой разброс и большая комбинация различных вариантов (которую до сих пор ещё полностью не выделила) ...И в которые постоянно добавляются новые строки с новыми правилами......Просто оно очень большое и неоднозначное.....
Андрей VG, в любом случае, БОЛЬШОЕ СПАСИБО. Теперь я хотя бы поняла, какие примеры с книжки можно адаптировать, а какие нет (буду двигаться ТОЛЬКО по диалекту Javascript ДЛЯ ЕГО НАПИСАНИЯ В VBScript.RegExp)
Андрей VG, окей Я бы хотела в Ваш шаблон (который работает) "(.{16,}?)(?:;(?: {0,4}-| |$)|: {0,4}-)"
и
1. ГОТОВА КОНЦЕРВОВАНА РИБА У ГЕРМЕТИЧНО ЗАКРИТИХ ПОСУДИНАХ - "ПРЕСЕРВИ": -ШМАТОЧКИ ФІЛЕ ОСЕЛЕДЕЦЯ БЕЗ ШКІРИ В ОЛІЇ 500ГР; -ФІЛЕ ОСЕЛЕДЕЦЯ БЕЗ ШКІРИ В ОЛІЇ 750ГР;
1. ГОТОВА КОНЦЕРВОВАНА РИБА У ГЕРМЕТИЧНО ЗАКРИТИХ ПОСУДИНАХ - "ПРЕСЕРВИ": -ПРЕСЕРВИ РИБНІ ОСЕЛЕДЕЦЬ В ОЛІЇ 180ГР ТМ"ОХОТСКАЯ"-1ШТ; -ПРЕСЕРВИ РИБНІ ОСЕЛЕДЕЦЬ В ОЛІЇ З АРОМАТОМ ПАПРИКИ 180ГР ТМ"ОХОТСКАЯ"-1ШТ; -ПРЕСЕРВИ РИБНІ ОСЕЛЕДЕЦЬ З МОРСЬКОЮ КАПУСТОЮ 500ГР ТМ"ОХОТСКАЯ"-1ШТ; -ПРЕСЕРВИ РИБНІ ОСЕЛЕДЕЦЬ В ОЛІЇ "5 ПЕРЦІВ" 500ГР ТМ"NORVEN"-1ШТ; -ПРЕСЕРВИ РИБНІ ОСЕЛЕДЕЦЬ ПРЯНО-ПІКАНТНИЙ В ОЛІЇ 300ГР ТМ"NORVEN"-1ШТ; ВИРОБНИК: ТОВ "ЮФК" UA ЧАСТИНА МІСЦЯ - ВСЬОГО 5 БАНОК, ЗАПАКОВАНІ В ПОЛІМЕРНУ БАНКУ ОБТЯНУТІ П/П ПЛІВКОЮ, В ПІНОПЛАСТОВОМУ КОРОБІ З ЛЬОДОМ.
ещё предусмотреть разбитие строки по знаку "," но не так
Код
(.{16,}?)(?:;|,(?: {0,4}-| |$)|: {0,4}-)
- в данном случае оно разобьёт и по ";" и по "," после знака ":" а только в том случае, если между ":" и "." нет ";". То есть использовать условие Если то. Но как я понимаю - это в данном случае уже не получится, а только отдельным запросом к VBScript.RegExp.
Андрей VG, честно не понимаю, if then else - даёт возможность выбора варианта событий и при его наступлении поставить тот или иной оператор, а конструкция abc|bd даёт возможность только выбора abc или bd - без возможности задать условие, т.е всегда при наличии данных выражений.
Так программа тут на картинке ругается именно на знак "?" как символ, значит она не поддерживает и шаблоны по выбору : (?=шаблон) Позитивный просмотр вперёд Людовик(?=XVI) ЛюдовикXV, ЛюдовикXVI, ЛюдовикXVIII, ЛюдовикLXVII, ЛюдовикXXL (?!шаблон) Негативный просмотр вперёд (с отрицанием) Людовик(?!XVI) ЛюдовикXV, ЛюдовикXVI, ЛюдовикXVIII, ЛюдовикLXVII, ЛюдовикXXL (?<=шаблон) Позитивный просмотр назад (?<=Сергей )Иванов Сергей Иванов, Игорь Иванов (?<!шаблон) Негативный просмотр назад (с отрицанием) (?<!Сергей )Иванов Сергей Иванов, Игорь Иванов и значит VBA тоже не поддерживает?
так,я уже совсем ничего не понимаю, то о чём Вы говорите: (?=шаблон) Позитивный просмотр вперёд Людовик(?=XVI) ЛюдовикXV, ЛюдовикXVI, ЛюдовикXVIII, ЛюдовикLXVII, ЛюдовикXXL (?!шаблон) Негативный просмотр вперёд (с отрицанием) Людовик(?!XVI) ЛюдовикXV, ЛюдовикXVI, ЛюдовикXVIII, ЛюдовикLXVII, ЛюдовикXXL (?<=шаблон) Позитивный просмотр назад (?<=Сергей )Иванов Сергей Иванов, Игорь Иванов (?<!шаблон) Негативный просмотр назад (с отрицанием) (?<!Сергей )Иванов Сергей Иванов, Игорь Иванов