Доброе время суток, подскажите пожалуйста, возможно ли разнести значения по датам с одной таблице, в другу, что бы значения с датами сформировались в таблице по порядку?
Доброе время суток, подскажите пожалуйста, возможно ли разнести значения по датам с одной таблице, в другу, что бы значения с датами сформировались в таблице по порядку?Fokus
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]
вариант: [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
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]
Вот ещё вариант макросом [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