Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Разнести данные с таблице 1 в таблицу 2, по датам - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Разнести данные с таблице 1 в таблицу 2, по датам (Формулы/Formulas)
Разнести данные с таблице 1 в таблицу 2, по датам
Fokus Дата: Пятница, 28.04.2023, 07:25 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

2303
Доброе время суток, подскажите пожалуйста, возможно ли разнести значения по датам с одной таблице, в другу, что бы значения с датами сформировались в таблице по порядку?
К сообщению приложен файл: primer1.xlsx (12.8 Kb)
 
Ответить
СообщениеДоброе время суток, подскажите пожалуйста, возможно ли разнести значения по датам с одной таблице, в другу, что бы значения с датами сформировались в таблице по порядку?

Автор - Fokus
Дата добавления - 28.04.2023 в 07:25
jakim Дата: Пятница, 28.04.2023, 08:38 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1199
Репутация: 313 ±
Замечаний: 0% ±

Excel 2010
Power Query

[vba]
Код
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"№ п/п", type text}, {"Дата от", type date}, {"Дата до", type date}, {"Значение", type text}}),
    #"Added Custom" = Table.AddColumn(#"Changed Type", "Custom", each {Number.From([Дата от])..Number.From([Дата до])}),
    #"Expanded Custom" = Table.ExpandListColumn(#"Added Custom", "Custom"),
    #"Changed Type1" = Table.TransformColumnTypes(#"Expanded Custom",{{"Custom", type date}}),
    #"Removed Columns" = Table.RemoveColumns(#"Changed Type1",{"Дата от", "Дата до"}),
    #"Reordered Columns" = Table.ReorderColumns(#"Removed Columns",{"№ п/п", "Custom", "Значение"}),
    #"Renamed Columns" = Table.RenameColumns(#"Reordered Columns",{{"Custom", "Дата"}})
in
    #"Renamed Columns"
[/vba]
К сообщению приложен файл: 1979243.xlsx (23.9 Kb)
 
Ответить
Сообщение
Power Query

[vba]
Код
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"№ п/п", type text}, {"Дата от", type date}, {"Дата до", type date}, {"Значение", type text}}),
    #"Added Custom" = Table.AddColumn(#"Changed Type", "Custom", each {Number.From([Дата от])..Number.From([Дата до])}),
    #"Expanded Custom" = Table.ExpandListColumn(#"Added Custom", "Custom"),
    #"Changed Type1" = Table.TransformColumnTypes(#"Expanded Custom",{{"Custom", type date}}),
    #"Removed Columns" = Table.RemoveColumns(#"Changed Type1",{"Дата от", "Дата до"}),
    #"Reordered Columns" = Table.ReorderColumns(#"Removed Columns",{"№ п/п", "Custom", "Значение"}),
    #"Renamed Columns" = Table.RenameColumns(#"Reordered Columns",{{"Custom", "Дата"}})
in
    #"Renamed Columns"
[/vba]

Автор - jakim
Дата добавления - 28.04.2023 в 08:38
Fokus Дата: Пятница, 28.04.2023, 11:20 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

2303
jakim, Спасибо, вот бы еще понять как работает эта надстройка)
 
Ответить
Сообщениеjakim, Спасибо, вот бы еще понять как работает эта надстройка)

Автор - Fokus
Дата добавления - 28.04.2023 в 11:20
Nic70y Дата: Пятница, 28.04.2023, 12:37 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 8759
Репутация: 2273 ±
Замечаний: 0% ±

Excel 2010
вариант:
[vba]
Код
Sub u_628()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "g").End(xlUp).Row
    If a > 2 Then Range("g3:h" & a).Clear
    b = Cells(Rows.Count, "a").End(xlUp).Row
    If b > 2 Then
        For c = 3 To b
            d = Cells(Rows.Count, "g").End(xlUp).Row
            e = Range("c" & c) - Range("b" & c) + 1
            Range("b" & c).Copy
            Range("g" & d + 1 & ":g" & d + e).PasteSpecial Paste:=xlPasteFormats
            Range("g" & d + 1 & ":g" & d + e).FormulaR1C1 = "=ROW()-" & d & "-1+INDEX(C2," & c & ")"
            Range("g" & d + 1 & ":g" & d + e) = Range("g" & d + 1 & ":g" & d + e).Value
            Range("d" & c).Copy Range("h" & d + 1 & ":h" & d + e)
        Next
        f = Cells(Rows.Count, "g").End(xlUp).Row
        Range("g3:h" & f + 1).Sort key1:=Range("g3:g" & f + 1), order1:=xlAscending, Header:=xlNo
    End If
    Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: 5525098.xlsm (23.0 Kb)


ЮMoney 41001841029809
 
Ответить
Сообщениевариант:
[vba]
Код
Sub u_628()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "g").End(xlUp).Row
    If a > 2 Then Range("g3:h" & a).Clear
    b = Cells(Rows.Count, "a").End(xlUp).Row
    If b > 2 Then
        For c = 3 To b
            d = Cells(Rows.Count, "g").End(xlUp).Row
            e = Range("c" & c) - Range("b" & c) + 1
            Range("b" & c).Copy
            Range("g" & d + 1 & ":g" & d + e).PasteSpecial Paste:=xlPasteFormats
            Range("g" & d + 1 & ":g" & d + e).FormulaR1C1 = "=ROW()-" & d & "-1+INDEX(C2," & c & ")"
            Range("g" & d + 1 & ":g" & d + e) = Range("g" & d + 1 & ":g" & d + e).Value
            Range("d" & c).Copy Range("h" & d + 1 & ":h" & d + e)
        Next
        f = Cells(Rows.Count, "g").End(xlUp).Row
        Range("g3:h" & f + 1).Sort key1:=Range("g3:g" & f + 1), order1:=xlAscending, Header:=xlNo
    End If
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 28.04.2023 в 12:37
msi2102 Дата: Пятница, 28.04.2023, 14:20 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
Вот ещё вариант макросом
[vba]
Код
Sub Макрос_1()
    Dim arr1, arr2, y, n As Long, m As Long, i As Long
    arr1 = Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    Set scs = CreateObject("System.Collections.SortedList")
    For n = 1 To UBound(arr1)
        If IsDate(arr1(n, 2)) And IsDate(arr1(n, 3)) Then
            For m = CDate(arr1(n, 2)) To CDate(arr1(n, 3))
                If Not scs.contains(m) Then Set scs(m) = CreateObject("System.Collections.ArrayList")
                If Not scs(m).contains(arr1(n, 4)) Then scs(m).Add arr1(n, 4): i = i + 1
            Next
        End If
    Next
    ReDim arr2(1 To i, 1 To 2)
    i = 1
    For n = 0 To scs.Count - 1
'        scs(scs.getkey(n)).Sort 'Если нужна будет сортировка внутри даты
        For Each y In scs(scs.getkey(n))
            arr2(i, 1) = scs.getkey(n)
            arr2(i, 2) = y
            i = i + 1
        Next
    Next
    Range("J3").Resize(UBound(arr2), 2) = arr2
End Sub
[/vba]
К сообщению приложен файл: 6874757.xlsm (23.0 Kb)
 
Ответить
СообщениеВот ещё вариант макросом
[vba]
Код
Sub Макрос_1()
    Dim arr1, arr2, y, n As Long, m As Long, i As Long
    arr1 = Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    Set scs = CreateObject("System.Collections.SortedList")
    For n = 1 To UBound(arr1)
        If IsDate(arr1(n, 2)) And IsDate(arr1(n, 3)) Then
            For m = CDate(arr1(n, 2)) To CDate(arr1(n, 3))
                If Not scs.contains(m) Then Set scs(m) = CreateObject("System.Collections.ArrayList")
                If Not scs(m).contains(arr1(n, 4)) Then scs(m).Add arr1(n, 4): i = i + 1
            Next
        End If
    Next
    ReDim arr2(1 To i, 1 To 2)
    i = 1
    For n = 0 To scs.Count - 1
'        scs(scs.getkey(n)).Sort 'Если нужна будет сортировка внутри даты
        For Each y In scs(scs.getkey(n))
            arr2(i, 1) = scs.getkey(n)
            arr2(i, 2) = y
            i = i + 1
        Next
    Next
    Range("J3").Resize(UBound(arr2), 2) = arr2
End Sub
[/vba]

Автор - msi2102
Дата добавления - 28.04.2023 в 14:20
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Разнести данные с таблице 1 в таблицу 2, по датам (Формулы/Formulas)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!