Re: Code to insert fields onto existing worksheet
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?
Re: Code to insert fields onto existing worksheet
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?
Re: Code to insert fields onto existing worksheet
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.
Re: Code to insert fields onto existing worksheet
Quote:
Originally Posted by
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?
They will be both alpha and numeric.
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
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.
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
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.
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
I just didn't show all the columns in the previous screen shot. See attached, for my thought on "step 1."
Re: Code to insert fields onto existing worksheet
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
Code:
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
Re: Code to insert fields onto existing worksheet
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
Code:
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
Re: Code to insert fields onto existing worksheet
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:
Code:
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
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
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
Re: Code to insert fields onto existing worksheet
couple of changes:
Code:
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).
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
It's still not doing it properly. Please see attached file. Thanks for your help with this. Really appreciate it.
Re: Code to insert fields onto existing worksheet
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.
Re: Code to insert fields onto existing worksheet
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.
Re: Code to insert fields onto existing worksheet
If you know which columns to delete (ie. if it's always column P), it's simply this:
Code:
ws.range("p1").entirecolumn.delete
Re: Code to insert fields onto existing worksheet
Thanks. I will need to add the extra columns using this code
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?
Re: Code to insert fields onto existing worksheet
I would say so, yes. Make sure you have all the details copied over, then put headers in, and do formatting, etc.
