Excel VBA дублирует строки и увеличивает дату - PullRequest
Новая
       13

Excel VBA дублирует строки и увеличивает дату

0 голосов
/ 18 марта 2019

У меня есть лист Excel с 170 сотрудниками, и мне нужно продублировать эти строки, чтобы иметь по одной строке на сотрудника в день месяца.

Мне удалось использовать VBA для дублирования строк, но это прямая копия даты, и я хочу, чтобы она увеличилась, чтобы у каждого была строка для каждой уникальной даты месяца. Что я использую до сих пор: 

Sub TimesThirty()
Dim LR As Long:     LR = Range("A" & Rows.Count).End(xlUp).Row
Dim BR As Long:     BR = LR * 31

Rows("1:" & LR).Copy Rows(LR + 1 & ":" & BR)
Range("A1").CurrentRegion.Sort Key1:=[A1], Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal

End Sub

Спасибо за любую помощь.

пример настройки столбцов:

1 Ответ

1 голос
/ 18 марта 2019

Это должно работать для вас. Если вам нужна помощь в реализации этого, не стесняйтесь спрашивать: 

Option Explicit
Sub TimesThirty()
    Dim LR As Long:     LR = Range("A" & Rows.Count).End(xlUp).Row
    Dim BR As Long:     BR = LR * Day(Application.EoMonth(Date, 1)) 'this way it will do it for the number of days of the current month
    Dim arrData As Variant, ws As Worksheet, x As Integer, i As Long, h As Long

    Set ws = ThisWorkbook.Sheets("Name") 'change name for the name of your sheet

    With ws
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column 'last column on your sheet
        arrData = .Range(.Cells(1, 1), .Cells(BR, x)).Value

        'A loop through the array to copy the values except the Date which will go adding a day each loop
        For i = 1 To LR 'for every worker
            For h = 1 To Day(Application.EoMonth(Date, 1)) 'for every day of the month
                For x = 1 To UBound(arrData, 2) 'for every column
                    If x = 1 Then 'I'm assuming the Date is on the column 1, else change the value of x
                        arrData(LR + h, x) = DateSerial(Year(arrData(i, x)), Month(arrData(i, x)), h) 'Year, Month, Day
                    Else
                        arrData(LR + h, x) = arrData(i, x) 'copy the same value
                    End If
                Next x
            Next h
        Next i

        .Range(.Cells(1, 1), .Cells(BR, x)).Value = arrData 'Paste the array back to the sheet

    End With


End Sub
...