Если подойдет, то попробуйте с помощью макроса (он во вложении). Перейдите на лист "Обработка", нажмите на кнопку "Получить отчет" и все. Макрос переберет все файлы в выбранной папке начинающиеся с "actreturn" и исправит ячейку с "№ п/п" в них, а потом запустит обновление всех запросов PQ. Этот вариант кривенький, но лучше чем ничего.
Если не ошибаюсь то, что выгружаются не все данные связано с объединением ячеек. "№ п\п" занимает 3 ячейки по горизонтали, а другие заголовки шапки таблицы по 2. Может быть тот кто выгружает эти файлы исправит свою выгрузку? Ну или на худой конец можно написать макрос который будет исправлять шапку.
Александр, здравствуйте. Попробуйте мой вариант. Работает так - открываете "Книга2.xlsx", переходите на лист "Настройки" там указываете имя файла из которого загружать данные, а потом на вкладке "Данные" кликаете по "Обновить все" (Ctrl+Alt+F5). Результат работы запроса PQ выгружается на лист "Отчет".
PS. На всякий случай прикладываю файл из которого загружал данные ("Пример_1.xlsx")
let
source= Excel.CurrentWorkbook(){[Name="tblData"]}[Content],
chtype = Table.TransformColumnTypes(source,{{"ФИО", type text}, {"Дата", type date}}),
out = Table.Group(chtype, {"ФИО"}, {{"Макс дата", each List.Max([Дата]), type date}})
in
out
или еще макрос:
Код
Sub groupByFIO_Date()
Dim j As Long
Dim iLastRow As Long
Dim arrSour As Variant
Dim Dict As Object
Dim Key As String
Dim Item As Date
Set Dict = CreateObject("Scripting.Dictionary")
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("D2:E" & iLastRow).ClearContents
arrSour = Range("A1:B" & iLastRow)
For j = 2 To UBound(arrSour, 1)
Key = CStr(arrSour(j, 1))
Item = CDate(arrSour(j, 2))
If Not Dict.Exists(Key) Then
Dict.Add Key, Item
Else
If Dict.Item(Key) < Item Then
Dict.Item(Key) = Item
End If
End If
Next j
Erase arrSour
ReDim arrSour(0 To Dict.Count - 1, 0 To 1)
With Dict
For j = 0 To .Count - 1
arrSour(j, 0) = .Keys()(j)
arrSour(j, 1) = .Items()(j)
Next
End With
Cells(2, 4).Resize(UBound(arrSour) + 1, 2).Value = arrSour
End Sub
Здравствуйте. Если правильно понял то выгружать Большой запрос на лист не нужно, в "Закрыть и сохранить" выберите "Только создать подключение". Потом в списке запросов правой кнопкой мыши по Большому запросу и выбрать "Ссылка". Создастся новый запрос на основе Большого запроса, т.е. данные запрашиваться не будут, а будут использованы полученные в Большом запросе. Ну, а дальше крутите-вертите новый запрос и выводите куда нужно.
Здравствуйте. Возможно ошибка связана с тем что в заголовке файла не прописана кодовая страница (она равна 0) Попробуйте такой запрос в PowerQuery:
Код
let
source = OleDb.Query("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=d:\Wrk\Kwork\getData\;Extended Properties='dBASE IV';", "Select * From [1STOPER.DBF]"),
a = Table.TransformColumns(source, {}, (x)=> Text.FromBinary(Text.ToBinary(Text.From(x), 866), 1251))
in
a
На всякий случай - не забудьте исправить путь к своему файлу (замените вот это d:\Wrk\Kwork\getData\ на своё)
PS. Исправил заголовок в Вашем файле. Попробуйте теперь открыть его в своём коде.
Вы скачали файл xlsx с сайта и теперь хотите обработать его с помощью PowerQuery? Если я правильно понял то напишите что нужно получить в результате работы PQ.
Sub ExportToCSV_UTF8()
'CSV в кодировке UTF8+BOM
Dim wb As Workbook
Dim ws As Worksheet
Dim sSymbol As String, txt As String
Dim i As Long, j As Long, RowsLimit As Long
Dim arr(), arr2()
Dim s As String
Dim oStream
If MsgBox("Сохранить лист в CSV?", vbQuestion + vbYesNo, "Вопросы") = vbNo Then Exit Sub
sSymbol = "|" 'символ-разделитель
RowsLimit = 3000 'кол-строк строк в 1 файле
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Set ws = ActiveWorkbook.Worksheets("Итоговые цены")
arr = ws.UsedRange.Value
For i = LBound(arr, 1) To UBound(arr, 1)
ReDim Preserve arr2(i - 1)
For j = LBound(arr, 2) To UBound(arr, 2)
If txt = "" Then
txt = arr(i, j)
Else
txt = txt & sSymbol & arr(i, j)
End If
Next j
arr2(i - 1) = txt
txt = ""
Next i
For i = LBound(arr2) To UBound(arr2) Step RowsLimit
s = ""
For j = i To i + (RowsLimit - 1)
If j > UBound(arr2) Then Exit For
s = s & arr2(j) & vbNewLine
Next j
If s <> "" Then
Set oStream = CreateObject("ADODB.Stream")
With oStream
.Open
.Charset = "utf-8"
.WriteText s
.SaveToFile "d:\Clouds\Yandex.Disk\Магазин\pricelists\import\Prices_marketplaces_from_" & i & "_to_" & i + RowsLimit & ".csv", 2
End With
Set oStream = Nothing
End If
Next i
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Готово", vbInformation, "Конец"
End Sub
Если после названия города всегда идет "Автоколона..." то можете найти позицию "Автоколона" в строке и потом извлечь из строки символы до позиции "Автоколона" - 2
Здравствуйте. Можно сделать всё в одной книге: 1. Добавить лист настроек со столбцами: "id сотрудника", "категория сотрудника" (менеджер, нач.сектора, нач.отдела), сектор, отдел. 2. Создать форму логирования которую вызывать при открытии книги. 3. На основании данных пользователя, введенных в форме логирования, отображать/скрывать колонки. Т.е. для уровня менеджера свои колонки, для нач.сектора свои и для начальника отдела свои.
а вот как потом его сджойнить с таблицей Spravochnik?
например так
Код
select spr.*, max(Date_last_maintenance), teh."Vehicle status" from Teh_obsluzhivanie teh
inner join Spravochnik spr on spr.cod_product = teh.product_cod
group by teh.product_cod
PS. проверял в SQLite + есть замечание - БД не нормализована (добавил бы таблицы: "цвет авто", "модель авто", "статус")
написал макрос. пустые строки пока оставил и если устроит такой вариант то удалю. работает так - жмете Alt+F8 -> выбираете макрос transformData и кликаете по кнопке "Выполнить". данные переносятся на лист "Как надо"
можете привести пример того, что должно удалиться по 3-м параметрам, но не удаляется? и что значит " пустые значения по столбцу, Р вписать не получается"? нужно удалить если в столбце Р пустое значение не глядя на другие столбцы?
Сделал в PowerQuery. На листе "Сравнение" жмете на кнопку "Обработка", запускается обновление запроса на подбор данных по условию и результат работы запроса выводится на лист "Обработанные". У меня древний ноут (10 лет) на нем запрос на урезанных данных выполняется примерно за 1 сек. Интересно узнать не будет ли тормозить запрос на полных данных.
Найти непустые строки и создать из них нумерованный список, В столбце AN необходимо найти непустые строки. Затем в соседнем столбце создать нумерованный список из этих строк.
Function changeOrder(val As String) As String
Dim i As Integer
Dim word1 As String, word2 As String, sTmp As String
word1 = ""
word2 = ""
For i = 1 To Len(val)
sTmp = Mid(val, i, 1)
If IsNumeric(sTmp) Then
word2 = word2 & sTmp
Else
word1 = word1 & sTmp
End If
Next i
changeOrder = word1 & word2
End Function
Sub sumByColor()
Dim sh As Worksheet
Dim i As Long
Dim summ As Double
Set sh = ThisWorkbook.Sheets("Лист1")
sh.Select
i = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
summ = 0
Do While i <> 1
If sh.Cells(i, 1).Interior.ColorIndex = xlNone Then
sh.Cells(i, 5) = CDbl(sh.Cells(i, 2)) + summ
summ = 0
Else
summ = summ + CDbl(sh.Cells(i, 2))
End If
i = i - 1
Loop
End Sub