Добрый вечер! Подскажите, пожалуйста. Есть график, в нем прописаны работы и периоды ее выполнения по датам. На втором листе есть те же даты и необходимо, чтобы ячейки рядом с датами заполнились работами из графика. Если в этот день работ несколько, то они должны добавляться через точку с пробелом. Более наглядно описано в примере. Заранее благодарен.
Добрый вечер! Подскажите, пожалуйста. Есть график, в нем прописаны работы и периоды ее выполнения по датам. На втором листе есть те же даты и необходимо, чтобы ячейки рядом с датами заполнились работами из графика. Если в этот день работ несколько, то они должны добавляться через точку с пробелом. Более наглядно описано в примере. Заранее благодарен.CHEVRYACHOK
With Sheets("График") Wrks = .Range("D7", .Cells(Rows.Count, 4).End(xlUp)).Value x = .Range("R6", .Cells(6, Columns.Count).End(xlToLeft)).Resize(UBound(Wrks) + 1).Value End With ReDim y(1 To UBound(x, 2), 1 To 2)
For j = 1 To UBound(x, 2) y(j, 1) = x(1, j) For i = 2 To UBound(x, 1) If Len(x(i, j)) Then y(j, 2) = IIf(IsEmpty(y(j, 2)), Wrks(i - 1, 1), y(j, 2) & ". " & Wrks(i - 1, 1)) Next i Next j
With Sheets("Раздел 3") .Range("A5").CurrentRegion.Offset(1).ClearContents .Range("A5").Resize(UBound(y, 1), UBound(y, 2)).Value = y End With End Sub
[/vba]
CHEVRYACHOK, привет попробуйте так: [vba]
Код
Sub ertert() Dim Wrks, x, y(), i&, j&
With Sheets("График") Wrks = .Range("D7", .Cells(Rows.Count, 4).End(xlUp)).Value x = .Range("R6", .Cells(6, Columns.Count).End(xlToLeft)).Resize(UBound(Wrks) + 1).Value End With ReDim y(1 To UBound(x, 2), 1 To 2)
For j = 1 To UBound(x, 2) y(j, 1) = x(1, j) For i = 2 To UBound(x, 1) If Len(x(i, j)) Then y(j, 2) = IIf(IsEmpty(y(j, 2)), Wrks(i - 1, 1), y(j, 2) & ". " & Wrks(i - 1, 1)) Next i Next j
With Sheets("Раздел 3") .Range("A5").CurrentRegion.Offset(1).ClearContents .Range("A5").Resize(UBound(y, 1), UBound(y, 2)).Value = y End With End Sub
можно сводной создал именованный диапазон tbl (График!$D$6:$AU$14), по ней построил консолидированную сводную (через мастер сводных таблиц и диаграмм)
можно сводной создал именованный диапазон tbl (График!$D$6:$AU$14), по ней построил консолидированную сводную (через мастер сводных таблиц и диаграмм)krosav4ig
nilem, krosav4ig, огромное Вам спасибо! Оба варианта работают, но вариант с макросом более приемлем. nilem, не могли бы Вы, если Вас не затруднит, помочь с первым пунктом - заполнение 1-цами графика? Еще раз спасибо!
nilem, krosav4ig, огромное Вам спасибо! Оба варианта работают, но вариант с макросом более приемлем. nilem, не могли бы Вы, если Вас не затруднит, помочь с первым пунктом - заполнение 1-цами графика? Еще раз спасибо!CHEVRYACHOK
Сообщение отредактировал CHEVRYACHOK - Воскресенье, 23.10.2016, 18:29
Sub Edinichki() Dim x, y(), i&, j&, k& Dim dtBg As Date, dtEd As Date With Sheets("График") With .Range("L7:Q" & .Cells(Rows.Count, "L").End(xlUp).Row) dtBg = WorksheetFunction.Min(.Cells) dtEd = WorksheetFunction.Max(.Cells) x = .Value End With End With
ReDim y(1 To UBound(x) + 1, 1 To dtEd - dtBg + 1) For j = 1 To UBound(y, 2) y(1, j) = dtBg + j - 1 Next j For i = 1 To UBound(x) For j = 1 To UBound(x, 2) Step 2 If IsDate(x(i, j)) Then For k = x(i, j) To x(i, j + 1) If Weekday(k, 0) < 7 Then y(i + 1, k - dtBg + 1) = 1 Next k End If Next j Next i
Sheets("График").Range("R6").Resize(UBound(y, 1), UBound(y, 2)).Value = y End Sub
[/vba]
как-то вот так, например:
[vba]
Код
Sub Edinichki() Dim x, y(), i&, j&, k& Dim dtBg As Date, dtEd As Date With Sheets("График") With .Range("L7:Q" & .Cells(Rows.Count, "L").End(xlUp).Row) dtBg = WorksheetFunction.Min(.Cells) dtEd = WorksheetFunction.Max(.Cells) x = .Value End With End With
ReDim y(1 To UBound(x) + 1, 1 To dtEd - dtBg + 1) For j = 1 To UBound(y, 2) y(1, j) = dtBg + j - 1 Next j For i = 1 To UBound(x) For j = 1 To UBound(x, 2) Step 2 If IsDate(x(i, j)) Then For k = x(i, j) To x(i, j + 1) If Weekday(k, 0) < 7 Then y(i + 1, k - dtBg + 1) = 1 Next k End If Next j Next i
Sheets("График").Range("R6").Resize(UBound(y, 1), UBound(y, 2)).Value = y End Sub