Code to insert fields onto existing worksheet

[fusion001]

Ok so the first part of the code is to determine the number of rows in each section. So say using the top part as an example I would need to find the number of rows and then I need to copy the range. In the above attachment I will need to copy the headings B1 to E1 across to the next available column (leaving one column bank) in this case G1 is where the headings will be copied to and the data range for Expenditure 1 is B5:E6. Then I insert the forecast columns.
But what I need to do is list all the department codes in a list for all the sections in order and not in each section. Will this need to done first before anything else?

[vbfbryce]

yes, you'd need to compile a complete list of departments first. i'd populate an array, checking each new row to see if the department number is already in the array. are they always numeric, no alpha?

[vbfbryce]

Or it might be just as easy to copy each section first, then compare across the three groups to determine when rows need to be added.

[fusion001]

yes, you'd need to compile a complete list of departments first. i'd populate an array, checking each new row to see if the department number is already in the array. are they always numeric, no alpha?

They will be both alpha and numeric.

[vbfbryce]

I would suggest you copy each "block" over to the right, then sort each block, then compare the rows to see which blocks are "missing departments."

The attached should illustrate what I'm suggesting. If you are okay with that approach, have a go at the first step: finding the first block and copying it over to the right.

[fusion001]

If I was to do that it that way then what would happen with all the amount columns in each section. I'm trying to understand the steps to get to where I need to get to. I'm attaching the example I attached earlier to explain what the starting format is and what the final format needs to be. Thanks.

[vbfbryce]

I just didn't show all the columns in the previous screen shot. See attached, for my thought on "step 1."

[fusion001]

Hi...I've done the first part of the code to split the sections across the columns like above example. The code I've done is

Sub CopyRanges()

Dim ws As Worksheet
Set ws = ActiveSheet

With ws
    .Range("A14").Select
    .Range(Selection, Selection.End(xlToRight)).Select
    .Range(Selection, Selection.End(xlDown)).Select
       Selection.Copy
    .Range("G14").Select
    ActiveSheet.PasteSpecial

.Range("A14").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Offset(1).Select
    .Range(Selection, Selection.End(xlToRight)).Select
    .Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    .Range("P14").Select
    ActiveSheet.PasteSpecial
    
    .Range("A14").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Offset(1).Select
    .Range(Selection, Selection.End(xlToRight)).Select
    .Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    .Range("Y14").Select
    ActiveSheet.PasteSpecial
    

End Sub

Can you please show me how I can sort/filter so all the departments are listed in order in the first column in this case column G. Thanks

[fusion001]

Hi...I've done the first part of the code to split the sections across the columns like above example. The code I've done is

Sub CopyRanges()

Dim ws As Worksheet
Set ws = ActiveSheet

With ws
    .Range("A14").Select
    .Range(Selection, Selection.End(xlToRight)).Select
    .Range(Selection, Selection.End(xlDown)).Select
       Selection.Copy
    .Range("G14").Select
    ActiveSheet.PasteSpecial

.Range("A14").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Offset(1).Select
    .Range(Selection, Selection.End(xlToRight)).Select
    .Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    .Range("P14").Select
    ActiveSheet.PasteSpecial
    
    .Range("A14").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Offset(1).Select
    .Range(Selection, Selection.End(xlToRight)).Select
    .Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    .Range("Y14").Select
    ActiveSheet.PasteSpecial
    

End Sub

Can you please show me how I can sort/filter so all the departments are listed in order in the first column in this case column G. Thanks

[vbfbryce]

Building on the code you show, the next bit of code will sort each of the 3 blocks, then go through each row and compare to find "missing departments." A couple of things to watch for: my sort code assumes no headers; you may need to change this, and secondly, I put the "department" in each row, in each block, whereas you may only want it in each row in the FIRST block:

Sub copyStuff()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim rngKey As Range
    Dim rngSort As Range
    Dim lastCol As Integer
    Dim lastRow As Integer
    Dim longList As Integer     'find the section with the most departments ***
    Dim min As String
    Dim max As String
    Dim mid As String
    Dim colMin As Integer
    Dim colMax As Integer
    Dim ro As Integer
    
    With ws
        .Range("A14").Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown)).Select
           Selection.Copy
        .Range("G14").Select
        ActiveSheet.PasteSpecial
    
    .Range("A14").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Offset(1).Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        .Range("P14").Select
        ActiveSheet.PasteSpecial
        
        .Range("A14").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Offset(1).Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        .Range("Y14").Select
        ActiveSheet.PasteSpecial
        
        Stop
        'sort #1
        lastCol = .Range("g14").End(xlToRight).Column
        lastRow = .Range("g14").End(xlDown).Row
        
        Set rngKey = .Range("g14:g" & lastRow)
        Set rngSort = .Range(Cells(14, 7), Cells(lastRow, lastCol))
        rngSort.Select
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add rngKey
            .SetRange rngSort
            .Header = xlNo     'change this to xlYes if you have headers ***
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        'sort #2
        lastCol = .Range("p14").End(xlToRight).Column
        lastRow = .Range("p14").End(xlDown).Row
        
        Set rngKey = .Range("p14:p" & lastRow)
        Set rngSort = .Range(Cells(14, 16), Cells(lastRow, lastCol))
        rngSort.Select
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add rngKey
            .SetRange rngSort
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        'sort #3
        lastCol = .Range("y14").End(xlToRight).Column
        lastRow = .Range("y14").End(xlDown).Row
        
        Set rngKey = .Range("y14:y" & lastRow)
        Set rngSort = .Range(Cells(14, 25), Cells(lastRow, lastCol))
        rngSort.Select
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add rngKey
            .SetRange rngSort
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        longList = .Range("g14").End(xlDown).Row
        If .Range("p14").End(xlDown).Row > longList Then
            longList = .Range("p14").End(xlDown).Row
        End If
        If .Range("y14").End(xlDown).Row > longList Then
            longList = .Range("y14").End(xlDown).Row
        End If
        Stop '************************************
        Dim g As String
        Dim p As String
        Dim y As String
        
        ro = 14
        
        While ro <= longList
            g = .Range("g" & ro).Value
            p = .Range("p" & ro).Value
            y = .Range("y" & ro).Value
            If g <> "" Or p <> "" Or y <> "" Then
                If g > p Or g > y Then
                    lastCol = .Range("g" & ro).End(xlToRight).Column
                    .Range(Cells(ro, 7), Cells(ro, lastCol)).Insert xlShiftDown
                    If p <= y Then
                        .Range("g" & ro).Value = p
                    Else
                        .Range("g" & ro).Value = y
                    End If
                ElseIf p > g Or p > y Then
                    lastCol = .Range("p" & ro).End(xlToRight).Column
                    .Range(Cells(ro, 16), Cells(ro, lastCol)).Insert xlShiftDown
                    If g <= y Then
                        .Range("p" & ro).Value = g
                    Else
                        .Range("p" & ro).Value = y
                    End If
                ElseIf y > g Or y > p Then
                    lastCol = .Range("y" & ro).End(xlToRight).Column
                    .Range(Cells(ro, 25), Cells(ro, lastCol)).Insert xlShiftDown
                    If g <= p Then
                        .Range("y" & ro).Value = g
                    Else
                        .Range("y" & ro).Value = p
                    End If
                Else
                    ro = ro + 1
                End If
                
                longList = .Range("g14").End(xlDown).Row
                If .Range("p14").End(xlDown).Row > longList Then
                    longList = .Range("p14").End(xlDown).Row
                End If
                If .Range("y14").End(xlDown).Row > longList Then
                    longList = .Range("y14").End(xlDown).Row
                End If
            Else
                'fill in missing departments?
            End If
        Wend
    End With
    Set ws = Nothing
End Sub

[fusion001]

I've added the code but it keeps looping incorrectly. Please see attached file. I've changed the range to A7 as that what it is on the spreadsheet. I want the department codes to be in column G only and remove from other columns.Thanks

[vbfbryce]

couple of changes:

Option Explicit

Sub copyStuff()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim rngKey As Range
    Dim rngSort As Range
    Dim lastCol As Integer
    Dim lastRow As Integer
    Dim longList As Integer     'find the section with the most departments ***
    Dim min As String
    Dim max As String
    Dim mid As String
    Dim colMin As Integer
    Dim colMax As Integer
    Dim ro As Integer
    
    With ws
        .Range("A7").Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown).Offset(-1, 4)).Select
           Selection.Copy
        .Range("G7").Select
        ActiveSheet.PasteSpecial
    
    .Range("A7").Select
        Selection.End(xlDown).Select
       ' Selection.End(xlDown).Select
        Selection.End(xlDown).Offset(1).Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown).Offset(-1)).Select
        Selection.Copy
        .Range("P7").Select
        ActiveSheet.PasteSpecial
        
        .Range("A7").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        'Selection.End(xlDown).Select
       ' Selection.End(xlDown).Select
        Selection.End(xlDown).Offset(1).Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown).Offset(-1)).Select
        Selection.Copy
        .Range("Y7").Select
        ActiveSheet.PasteSpecial
        
        Stop
        'sort #1
        lastCol = .Range("g7").End(xlToRight).Column
        lastRow = .Range("g7").End(xlDown).Row
        
        Set rngKey = .Range("g7:g" & lastRow)
        'Set rngSort = .Range(Cells(14, 7), Cells(lastRow, lastCol))    CHANGED TO BELOW ***
        Set rngSort = .Range(Cells(7, 7), Cells(lastRow, lastCol))
        rngSort.Select
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add rngKey
            .SetRange rngSort
            .Header = xlNo     'change this to xlYes if you have headers ***
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        'sort #2
        lastCol = .Range("p7").End(xlToRight).Column
        lastRow = .Range("p7").End(xlDown).Row
        
        Set rngKey = .Range("p7:p" & lastRow)
        'Set rngSort = .Range(Cells(14, 16), Cells(lastRow, lastCol))   CHANGED TO BELOW ***
        Set rngSort = .Range(Cells(7, 16), Cells(lastRow, lastCol))
        rngSort.Select
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add rngKey
            .SetRange rngSort
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        'sort #3
        lastCol = .Range("y7").End(xlToRight).Column
        lastRow = .Range("y7").End(xlDown).Row
        
        Set rngKey = .Range("y7:y" & lastRow)
        Set rngSort = .Range(Cells(7, 25), Cells(lastRow, lastCol)) 'changed ***
        rngSort.Select
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add rngKey
            .SetRange rngSort
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        longList = .Range("g7").End(xlDown).Row
        If .Range("p7").End(xlDown).Row > longList Then
            longList = .Range("p7").End(xlDown).Row
        End If
        If .Range("y7").End(xlDown).Row > longList Then
            longList = .Range("y7").End(xlDown).Row
        End If
        Stop '************************************
        Dim g As String
        Dim p As String
        Dim y As String
        
        ro = 7
        
        Stop
        
        While ro <= longList
            g = .Range("g" & ro).Value
            p = .Range("p" & ro).Value
            y = .Range("y" & ro).Value
            If g <> "" Or p <> "" Or y <> "" Then
                If g > p Then
                    If p <> "" Then
                        lastCol = .Range("g" & ro).End(xlToRight).Column
                        .Range(Cells(ro, 7), Cells(ro, lastCol)).Insert xlShiftDown
                        .Range("g" & ro).Value = p
                    Else
                        .Range("p" & ro).Value = g
                    End If
                ElseIf g > y Then
                    If y <> "" Then
                        lastCol = .Range("g" & ro).End(xlToRight).Column
                        .Range(Cells(ro, 7), Cells(ro, lastCol)).Insert xlShiftDown
                        .Range("g" & ro).Value = y
                    Else
                        .Range("y" & ro).Value = g
                    End If

                ElseIf p > g Then
                    If g <> "" Then
                        lastCol = .Range("p" & ro).End(xlToRight).Column
                        .Range(Cells(ro, 16), Cells(ro, lastCol)).Insert xlShiftDown
                        .Range("p" & ro).Value = g
                    Else
                        .Range("g" & ro).Value = p
                    End If
                ElseIf p > y Then
                    If y <> "" Then
                        lastCol = .Range("p" & ro).End(xlToRight).Column
                        .Range(Cells(ro, 16), Cells(ro, lastCol)).Insert xlShiftDown
                        .Range("p" & ro).Value = y
                    Else
                        .Range("y" & ro).Value = p
                    End If  'to here ***
                ElseIf y > g Then
                    If g <> "" Then
                        lastCol = .Range("y" & ro).End(xlToRight).Column
                        .Range(Cells(ro, 25), Cells(ro, lastCol)).Insert xlShiftDown
                        .Range("y" & ro).Value = g
                    Else
                        .Range("g" & ro).Value = y
                    End If
                ElseIf y > p Then
                    If p <> "" Then
                        lastCol = .Range("y" & ro).End(xlToRight).Column
                        .Range(Cells(ro, 25), Cells(ro, lastCol)).Insert xlShiftDown
                        .Range("y" & ro).Value = p
                    Else
                        .Range("p" & ro).Value = y
                    End If
                Else
                    ro = ro + 1
                End If
                
                longList = .Range("g7").End(xlDown).Row
                If .Range("p7").End(xlDown).Row > longList Then
                    longList = .Range("p7").End(xlDown).Row
                End If
                If .Range("y7").End(xlDown).Row > longList Then
                    longList = .Range("y7").End(xlDown).Row
                End If
            Else
                'fill in missing departments?
            End If
        Wend
    End With
    Set ws = Nothing
End Sub

If this is working as you expect, you can simply delete any columns necessary (like the department numbers after the first block).

[fusion001]

It's still not doing it properly. Please see attached file. Thanks for your help with this. Really appreciate it.

[vbfbryce]

When I run your current code, on that worksheet, I end up with the expected 3 blocks of data to the right, with each block having all 14 departments as expected. I can't duplicate your issue with department 12 repeating over and over.

[fusion001]

I've tried it on a different PC and it has worked. Strange but at least it works. I only need the departments listed on the first block and not the other two blocks. Once I have copied the headings from the original data across to the three blocks I will want to delete the columns with the original and shift all the other to the left to column A. I will then add the other columns needed. Once
Also I need this to loop as I will have up to four sheets with data in the same format.

[vbfbryce]

If you know which columns to delete (ie. if it's always column P), it's simply this:

ws.range("p1").entirecolumn.delete

[fusion001]

Thanks. I will need to add the extra columns using this code

    With ws
        .Range("g1").Value = "Forecast"
        .Range("g1:j1").MergeCells = True
        .Range("g1:j1").HorizontalAlignment = xlCenterAcrossSelection
        .Range("g1").Font.Bold = True
        .Range("g1").Font.Italic = True
        
        .Range("g2").Value = "Best"
        .Range("h2").Value = "Likely"
        .Range("i2").Value = "Worst"
        .Range("j2").Value = "Spread"
        .Range("g2:j2").Font.Bold = True
        .Range("g2:j2").Font.Italic = True
        .Range("g2:g" & lr).Interior.Color = 12379352
        .Range("h2:h" & lr).Interior.Color = 15986394
        .Range("i2:i" & lr).Interior.Color = 14281213
        .Range("j5").Formula = "=g5-i5"
        .Range("j5").Copy
        .Range("j6:j" & lr).PasteSpecial
        Application.CutCopyMode = False
        
        .Range("b" & lr + 2).FormulaR1C1 = "=SUM(R[" & 5 - (lr + 2) & "]C:R[-2]C)"
        .Range("b" & lr + 2).Copy
        .Range("c" & lr + 2 & ":e" & lr + 2).PasteSpecial
        .Range("g" & lr + 2 & ":j" & lr + 2).PasteSpecial
        Application.CutCopyMode = False
        .Range("a" & lr).Value = "Total"
        
        .Range("k1").Value = "Comments"
        .Range("k1").Font.Bold = True
        .Range("k1").Font.Italic = True
        .Range("k1").ColumnWidth = 20
        .Range("k1").HorizontalAlignment = xlCenter
        .Range("k1:k2").Merge
        .Range("g5").Select
    End With

Is it better to add this code in after the code to copy each block across?

[vbfbryce]

I would say so, yes. Make sure you have all the details copied over, then put headers in, and do formatting, etc.