Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel

Сообщение успешно добавлено.

Страницы: 1
RSS
Выборка данных из таблицы с заданными условиями, Выбрать данные из таблицы и перенести в другую таблицу
 
#1
01.06.2022 11:27:02
Здравствуйте.
Мне необходимо выбрать данные из одной таблицы и перенести их в другую. При этом пропуская ячейки в которых нет значений. При этом копируя названия и значения из ячеек из исходной таблицы. Во вложении файл с исходной таблицей и результатом, который хотелось бы получить.
Заранее спасибо.
 
 
 
#2
01.06.2022 12:23:22
Код
Sub CollectNonEmpty()
    Dim rr As Range
    With ActiveSheet
        Set rr = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
    End With
    Dim nRows As Long
    With rr
        nRows = WorksheetFunction.CountA(.Range(.Cells(3, 2), .Cells(.Rows.Count, .Columns.Count)))
    End With
    Dim arr As Variant
    Dim brr As Variant
    arr = rr
    ReDim brr(1 To nRows, 1 To 4)
    
    Dim y1 As Long
    Dim y2 As Long
    Dim x1 As Long
    For x1 = 2 To UBound(arr, 2)
    For y1 = 3 To UBound(arr, 1)
        If Not IsEmpty(arr(y1, x1)) Then
            y2 = y2 + 1
            brr(y2, 1) = arr(1, x1)
            brr(y2, 2) = arr(2, x1)
            brr(y2, 3) = arr(y1, 1)
            brr(y2, 4) = arr(y1, x1)
        End If
    Next
    Next
    
    With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
        .Value = brr
    End With
End Sub
 
 
 
#3
01.06.2022 12:48:04
Или таким макросом
Код
Sub Макрос1()
Dim rez As Variant, arr As Variant, x As Variant, y As Variant, n As Long, m As Long, dic As Object, dic1 As Object
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
arr = Sheets("Лист1").Range("A1:F" & Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row).Value
For m = 2 To UBound(arr, 2)
    If Not dic.exists(arr(1, m) & "|" & arr(1, m)) Then Set dic(arr(1, m) & "|" & arr(2, m)) = CreateObject("Scripting.Dictionary")
    For n = 3 To UBound(arr)
        If arr(n, m) <> "" Then dic(arr(1, m) & "|" & arr(2, m)).Add arr(n, 1), CStr(arr(n, m))
        If Not dic1.exists(arr(n, 1)) Then dic1(dic1.Count + 1) = arr(n, 1)
    Next n
Next m
ReDim rez(1 To dic1.Count, 1 To 4)
n = 0
For Each y In dic
    For Each x In dic(y)
        n = n + 1
        rez(n, 1) = Split(y, "|")(0)
        rez(n, 2) = Split(y, "|")(1)
        rez(n, 3) = x
        If IsNumeric(dic(y)(x)) Then rez(n, 4) = CDbl(dic(y)(x)) Else rez(n, 4) = dic(y)(x)
    Next x
Next y
Range("H:K").ClearContents
Sheets("Лист1").Cells(3, 8).Resize(UBound(rez, 1), UBound(rez, 2)) = rez
End Sub
 
 
 
#4
01.06.2022 13:19:08
Спасибо вам огромное. Работает обалденно. Я бы эту работу год делал. Можно ли к вам обращаться по подобным вопросам на прямую? Сколько стоит обычно такая работа?
 
 
 
#5
01.06.2022 14:38:56
Михаил Яровицын, можно. Пишите им личное сообщение. Слева под их ником находятся кнопки Сообщение и Email.
 
 
 
#6
01.06.2022 15:32:33
Цитата
Михаил Яровицын написал:
Можно ли к вам обращаться по подобным вопросам
Можете ещё писать в раздел РАБОТА там возможно быстрее исполнителя найдете
 
 
 
#7
01.06.2022 16:05:07
Можно ещё Power Query
Код
let
    Источник = Excel.Workbook(File.Contents(Excel.CurrentWorkbook(){[Name="Parameters"]}[Content]{0}[Path]), null, true),
    Лист1_Sheet = Источник{[Item="Лист1",Kind="Sheet"]}[Data],
    Заголовки = Table.PromoteHeaders(Лист1_Sheet, [PromoteAllScalars=true]),
    lst1 = Table.ColumnNames(Заголовки),
    lst3 = List.Accumulate(List.Zip({Table.ToRows(Заголовки){0}, lst1}), {}, (state, current) => if current{1} = null  then current{0} else state & {Text.Combine({Text.From(current{1}), Text.From(current{0})},"|")}),    
    lst4 = List.Zip({lst1, lst3}),
    Удаление = Table.Skip(Заголовки,1),
    Заголовки1 = Table.RenameColumns(Удаление,lst4),
    Несвернут = Table.UnpivotOtherColumns(Заголовки1, {"Column1"}, "Атрибут", "Значение"),
    Раздел = Table.SplitColumn(Несвернут, "Атрибут", Splitter.SplitTextByDelimiter("|", QuoteStyle.Csv), {"Атрибут.1", "Атрибут.2"}),
    Порядок = Table.ReorderColumns(Раздел,{"Атрибут.1", "Атрибут.2", "Column1", "Значение"}),
    Сорт = Table.Sort(Порядок,{{"Атрибут.1", Order.Ascending}, {"Атрибут.2", Order.Ascending}, {"Column1", Order.Ascending}})
in
    Сорт


На листе ПУТЬ напишите путь к файлу вместе с именем файла и нажмите ОБНОВИТЬ ВСЕ на вкладке ДАННЫЕ. Сейчас записан путь текущего файла, поэтому обновит изменения, только после обновления
 
 
 
#8
01.06.2022 16:14:45
КРОСС
 
 
 
#9
01.06.2022 19:33:19
Формулами.
 
 
 
Страницы: 1

Сообщение успешно добавлено.

Наверх