Dublicate row based on first 6 letters in Cell and paste to buttom, changing date and divide amount

[Konigsfeldt]

Hi all,

I have rows with budget amounts that are totals for a year, but want to split them into 4 in same sheet, changing the date from 01-01-20XX to 01-01, 01-04, 01-07 & 01-10 and furthermore divide the amount with 4. (So I can compare with actuals by quarter when pivoting)

The variable is in column "A", and says "Budget 2020", but next year it will say 2021, and so on - so it has to be "Budget" only, that determines whether it should be dublicated or not. Column "A" contains the value "Actual" as well. The sheet is called "Rawdata".

The code should do the following, from:

to:

Hope it makes sense, please reach out for further info if necessary.

Thanks in advance for any help received.

/Jacob

 

[braindiesel]

Sorry, been away...

I have tweaked the macro (below) to solve your three issues posted above and made some notes in the code for you

If this solves it, do we need to consider putting the data on a new sheet (the below method is simpler)

Sub quarterMe()
  
    Dim myDest As Long
    Dim stopHere As Long
    Dim myRow As Long
    Dim myLeft As String
    Dim myRight As String
    Dim mySortTop As Long
    Dim mySortBot As Long
  
  
  
    Range("E2").Select
    If ActiveCell.Offset(1, 0).Value <> "" Then
        Selection.End(xlDown).Select
        End If
    'THE NEXT LINE ADDS 1 extra row in between... if you want two, then change the line to myDest = Selection.Offset(3, 0).Row
    'with the SORT option at the end, you need at least one blank row or this macro will delete all of your data
    myDest = Selection.Offset(2, 0).Row
    mySortTop = Selection.Offset(2, 0).Row
    stopHere = Selection.Offset(1, 0).Row
    Range("E2").Select
    myRow = ActiveCell.Row
  
  
    Do Until myRow = stopHere
        myLeft = Left(Range("A" & myRow).Value, 6)
        myRight = Right(Range("A" & myRow).Value, 4)
        'Depending on your version, you may ned to put myLeft = Application.worksheetfunction. before the Left and Right in the above two lines
        'ex:myLeft = Application.worksheetfunction.Left(Range("A" & myRow).Value,6)
        Range("A" & myRow & ":M" & myRow).Copy Destination:=Range("A" & myDest & ":M" & myDest)
      
        If myLeft = "Budget" Then
            Range("A" & myDest & ":M" & myDest + 3).Select
            Selection.FillDown
            Range("E" & myDest).Select
            ActiveCell = DateSerial(Month:=1, Day:=1, Year:=myRight)
            ActiveCell.Offset(1, 0).Value = DateSerial(Month:=4, Day:=1, Year:=myRight)
            ActiveCell.Offset(2, 0).Value = DateSerial(Month:=7, Day:=1, Year:=myRight)
            ActiveCell.Offset(3, 0).Value = DateSerial(Month:=10, Day:=1, Year:=myRight)
            Range("M" & myDest).Resize(4, 1).Value = Range("M" & myDest).Value / 4
            myDest = myDest + 4
      
      
            Else
            myDest = myDest + 1
      
        End If
        myRow = myRow + 1
          
    Loop
    If ActiveCell.Offset(1, 0).Value <> "" Then Selection.End(xlDown).Select
    mySortBot = Selection.Row
  
    Range("A" & mySortTop & ":M" & mySortBot).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A" & mySortTop & ":A" & mySortBot) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A" & mySortTop & ":M" & mySortBot)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  
  
    'THIS PART DELETES THE ROWS USED AT THE END.
    'If you are deleting, not sure why you want the blank row in between
  
    Range("A1").End(xlDown).Select
    'If you want the blank row deleted as well, then remove the singe quote from the beginning of the next line
    'Selection.Offset(1, 0).Select
    Range("A2", Selection).Select
    Selection.EntireRow.Delete shift:=xlUp
  
End Sub