-
1 Attachment(s)
Code to insert fields onto existing worksheet
Hi...I need some help with vba code please. We get a worksheet each month where columns A to E are populated but the number of rows will vary each month. What I want to do is to run a code which will add another 5 fields (columns G to K - column J is a formula) with the colur formatting in each column.
As the number of rows will vary I need the correct number of rows to be added to the inserted columns. On the last row I also need to have a total for each column. The user will manually populate the added columns. I'm attaching a sample to make it easier to understand what I'm after.
Any help would be appreciated. Thanks
-
Re: Code to insert fields onto existing worksheet
Try something like this:
Code:
Sub addCols()
Dim ws As Worksheet
Dim j As Long
Dim lr As Long
Set ws = ActiveSheet
lr = ws.Range("a4").End(xlDown).Row 'in your example, row 15
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
Set ws = Nothing
End Sub
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
Hi...thanks so much for the code. It works nicely except for some reason it is adding the word TOTAL in the last row in column A above the other TOTAL. Please see attached file.
Also is it possible to format the new columns so that the text is the same as columns A to E and there is a border as per the original sample? Thanks so much.
-
Re: Code to insert fields onto existing worksheet
When you first get the spreadsheet with A-E populated, is the total row present, or no?
-
Re: Code to insert fields onto existing worksheet
Quote:
Originally Posted by
vbfbryce
When you first get the spreadsheet with A-E populated, is the total row present, or no?
It is not pouplated at the moment I added it manually but I can get the spreadsheet changed to include the total to columns A-E if it is easier?
-
Re: Code to insert fields onto existing worksheet
No, not necessary to have them populated. Probably easier without. Back in a few with update.
-
Re: Code to insert fields onto existing worksheet
Code:
Sub addCols()
Dim ws As Worksheet
Dim j As Long
Dim lr As Long
Set ws = ActiveSheet
lr = ws.Range("a4").End(xlDown).Row 'in your example, row 15
With ws
.Range("b1").Copy
.Range("g1").PasteSpecial
.Range("g2:j2").PasteSpecial
.Application.CutCopyMode = False
.Range("g1").Select
.Range("g1").Value = "Forecast"
.Range("g1:j1").MergeCells = True
.Range("g1:j1").HorizontalAlignment = xlCenterAcrossSelection
.Range("g2").Value = "Best"
.Range("h2").Value = "Likely"
.Range("i2").Value = "Worst"
.Range("j2").Value = "Spread"
.Range("b5:b" & lr).Copy
.Range("g5").PasteSpecial xlPasteFormats
.Range("h5").PasteSpecial xlPasteFormats
.Range("i5").PasteSpecial xlPasteFormats
.Range("j5").PasteSpecial xlPasteFormats
.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 + 2).Value = "Total" 'changed this to "lr +2"
.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
.Range("g1:j1").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
.Range("g2:i2").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
.Range("j2").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
.Range("k1:k2").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
With .Range("g3:g" & lr).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
With .Range("i3:i" & lr).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
With .Range("j3:j" & lr).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
With .Range("k3:k" & lr).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
End With
Set ws = Nothing
End Sub
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
Hi...that code works beautifully. Thanks so much. I have an added complication now. I have now been told that there will be 4 worksheets on the workbook with the same format so I need to apply the code to all 4 sheets. I also need to add a "Summary" sheet at the beginning to bring through the totals from the 4 sheets. I'm attaching a sample file. Can the code be easily modified to pick this up? Thanks again.
-
Re: Code to insert fields onto existing worksheet
Yeah, we can do that. I probably won't get back to it til tomorrow.
-
Re: Code to insert fields onto existing worksheet
Quote:
Originally Posted by
vbfbryce
Yeah, we can do that. I probably won't get back to it til tomorrow.
OK thanks but if you get a chance to look at it today that would really help me please. :)
-
Re: Code to insert fields onto existing worksheet
Updated to loop through all sheets with names starting with "Dept" and then add Summary sheet (note that you'll have to do some formatting of the summary sheet similar to what I did for the totals in the Dept sheets):
Code:
Sub addCols()
Dim wb As Workbook '*********************************************8
Dim ws As Worksheet
Dim h As Integer
Dim j As Long
Dim lr As Long
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
For h = 1 To wb.Worksheets.Count
If Left(wb.Worksheets(h).Name, 3) = "Sum" Then
Application.DisplayAlerts = False
wb.Worksheets(h).Delete
Exit Sub
End If
Next h
For h = 1 To wb.Worksheets.Count
If Left(wb.Worksheets(h).Name, 4) = "Dept" Then
Set ws = wb.Worksheets(h)
ws.Select
lr = ws.Range("a4").End(xlDown).Row 'in your example, row 15
With ws
.Range("b1").Copy
.Range("g1").PasteSpecial
.Range("g2:j2").PasteSpecial
.Application.CutCopyMode = False
.Range("g1").Select
.Range("g1").Value = "Forecast"
.Range("g1:j1").MergeCells = True
.Range("g1:j1").HorizontalAlignment = xlCenterAcrossSelection
.Range("g2").Value = "Best"
.Range("h2").Value = "Likely"
.Range("i2").Value = "Worst"
.Range("j2").Value = "Spread"
.Range("b5:b" & lr).Copy
.Range("g5").PasteSpecial xlPasteFormats
.Range("h5").PasteSpecial xlPasteFormats
.Range("i5").PasteSpecial xlPasteFormats
.Range("j5").PasteSpecial xlPasteFormats
.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 + 2).Value = "Total" 'changed this to "lr +2"
.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
.Range("g1:j1").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
.Range("g2:i2").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
.Range("j2").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
.Range("k1:k2").BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
With .Range("g3:g" & lr).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
With .Range("i3:i" & lr).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
With .Range("j3:j" & lr).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
With .Range("k3:k" & lr).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlColorIndexAutomatic
End With
End With
Set ws = Nothing
End If
Next h
'create summary
wb.Sheets.Add before:=wb.Worksheets(1)
wb.Worksheets(1).Name = "Summary"
Set ws = wb.Worksheets("Summary")
With ws
.Range("a3").Value = "Department"
.Range("b3").Value = "Amount1"
.Range("c3").Value = "Amount2"
.Range("d3").Value = "Amount3"
.Range("e3").Value = "Total"
.Range("g3").Value = "Forecast"
'best, likely, etc...
For h = 2 To wb.Worksheets.Count
If Left(wb.Worksheets(h).Name, 4) = "Dept" Then
ws.Range("a" & 4 + h).Value = wb.Worksheets(h).Name
lr = wb.Worksheets(h).Range("a" & Rows.Count).End(xlUp).Row
For j = 2 To 5
ws.Cells(4 + h, j) = wb.Worksheets(h).Cells(lr, j)
Next j
For j = 7 To 10
'ws.Cells(4 + h, j) = wb.Worksheets(h).Cells(lr, j)
'ActiveCell.FormulaR1C1 = "=Dept1!R[11]C"
ws.Cells(4 + h, j).FormulaR1C1 = "=" & wb.Worksheets(h).Name & "!R[" _
& lr - (4 + h) & "]C"
Next j
End If
Next h
End With
Set wb = Nothing
Application.ScreenUpdating = True
End Sub
-
Re: Code to insert fields onto existing worksheet
Thanks so much for this. I'll copy the formatting from the first part of the code. This code will work fine for all sheets starting with "Dept" but I may also get files in exactly the same format but each sheet might have a completely different name and won't start with "Dept". For example, sheet 1 might be named "New York", sheet 2 "LA", sheet 3 "Washington" etc. Can this code handle this? I'm sorry to be a pain. Thanks again.
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
Hi...I've edited the code for the formatting and it works fine. I would like to format the numbers so they are all comma separated in all columns (1,000) and also have a total on the summary sheet like on the other sheets. Also on the Summary sheet the colour formatting is copying down to row 15 rather than just 4 rows. I'm attaching the file. Thanks again.
-
Re: Code to insert fields onto existing worksheet
Quote:
Originally Posted by
fusion001
Thanks so much for this. I'll copy the formatting from the first part of the code. This code will work fine for all sheets starting with "Dept" but I may also get files in exactly the same format but each sheet might have a completely different name and won't start with "Dept". For example, sheet 1 might be named "New York", sheet 2 "LA", sheet 3 "Washington" etc. Can this code handle this? I'm sorry to be a pain. Thanks again.
Hi just a quick update on this. I said each worksheet can have a different name but I've seen that they all start with Output1 (LA), Output1 (NY), Output1(WA), etc. So maybe this makes it easier. But what I would like to have is on the Summary sheet just to list the names as LA, NY, WA on each row without the word Output1 in front. Thanks.
-
Re: Code to insert fields onto existing worksheet
Assuming your sheet names always end in (xx) where "xx" is a two character state abbreviation, look for this spot and make these changes:
Code:
Dim tmpName As String '*** add this
For h = 2 To wb.Worksheets.Count
'If Left(wb.Worksheets(h).Name, 4) = "Dept" Then
If Left(wb.Worksheets(h).Name, 4) = "Outp" Then 'changed ***
'ws.Range("a" & 4+h).Value=mid(wb.Worksheets(h).name)
tmpName = wb.Worksheets(h).Name 'added ***
tmpName = Right(tmpName, 3) 'added ***
tmpName = Left(tmpName, 2) 'added ***
'ws.Range("a" & 4 + h).Value = wb.Worksheets(h).Name
ws.Range("a" & 4 + h).Value = tmpName 'changed ***
lr = wb.Worksheets(h).Range("a" & Rows.Count).End(xlUp).Row
For j = 2 To 5
Toward the very end, this would have to change to handle the spaces and "()" in the sheet names:
Code:
ws.Cells(4 + h, j).FormulaR1C1 = "='" & wb.Worksheets(h).Name & "'!R[" _
& lr - (4 + h) & "]C"
Not sure at this point which of the other issues (formatting maybe?) you're still having...
-
Re: Code to insert fields onto existing worksheet
Thanks for that. If the names are longer than two characters where do I need to change the code? Thanks so much for your help with this. I really appreciate it.
-
Re: Code to insert fields onto existing worksheet
You're saying that within the parentheses there may be more than two characters, yeah?
-
Re: Code to insert fields onto existing worksheet
Yeah. Some sheets could have a name like Output1(LA), output1(WARR) etc. Thanks.
-
Re: Code to insert fields onto existing worksheet
updated:
Code:
Dim tmpName As String '*** add this
Dim leftP As Integer 'position of "("
Dim rightP As Integer 'position of ")"
For h = 2 To wb.Worksheets.Count
'If Left(wb.Worksheets(h).Name, 4) = "Dept" Then
If Left(wb.Worksheets(h).Name, 4) = "Outp" Then 'changed ***
'ws.Range("a" & 4+h).Value=mid(wb.Worksheets(h).name)
tmpName = wb.Worksheets(h).Name 'added ***
leftP = InStr(1, tmpName, "(")
If leftP > 0 Then
rightP = InStr(leftP, tmpName, ")")
If rightP > 0 Then
tmpName = Mid(tmpName, leftP + 1, (rightP - leftP - 1))
Else
MsgBox "Worksheet name does not have ) in it"
Exit Sub
End If
Else
MsgBox "Worksheet name does not have ( in it"
Exit Sub
End If
'tmpName = Right(tmpName, 3) 'added ***
'tmpName = Left(tmpName, 2) 'added ***
'ws.Range("a" & 4 + h).Value = wb.Worksheets(h).Name
ws.Range("a" & 4 + h).Value = tmpName 'changed ***
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
Thanks so much for the code. I will update it and try it. I have now been told that we could have this report in a different format as well where it is split by Expenditure and Income on each worksheet. So one part will have the expenditure figures and the totals then and the bottom part for the income figures and totals and then a grand total. The number of rows could vary between each part and worksheets. A summary sheet is also required as in the original scenario.
I am attaching a sample to explain what I need to do. Please note that I have not formatted the boxes etc. on the file which I will need to do for a neat presentation.
I will use the code you have provided for the original format of the worksheets but can this code be tweaked for this new scenario? Thanks again
-
Re: Code to insert fields onto existing worksheet
It can certainly be tweaked for the new scenario; I'd like to see you attempt it first, and ask for help if you don't succeed.
-
Re: Code to insert fields onto existing worksheet
Quote:
Originally Posted by
vbfbryce
It can certainly be tweaked for the new scenario; I'd like to see you attempt it first, and ask for help if you don't succeed.
LOL now you're asking! I wish I was a quarter as good as you.
I've been told that the format of the report might change in terms of Expendiure and Income shown along the columns so the department codes are only shown once and the figures in the apporpriate columns. So the Best, Likely, Worst columns need to be added to each section after Expenditure and Income.
If I do the template can you please check if it will still be case of tweaking the existing code? Thanks
-
Re: Code to insert fields onto existing worksheet
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
Quote:
Originally Posted by
vbfbryce
sure thing
Please find attached sample to give you an idea. The formatting (borders, etc) is not exact and also I will need a summary sheet as previous examples. The coloured columns will be manually completed. Thanks
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
So is the top part of the attached image how the "before" will look, and the bottom part the "after?"
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
Hi I want to end up with the "After" but the start will be like this
Attachment 118187
The expenditure figures will be above the Income figures. The Departments should only be listed once where they are both in the Expenditure and Income. I hope this makes sense. Thanks
-
Re: Code to insert fields onto existing worksheet
Please zip/attach the before and after; an image is hard to see, and it appears the number of columns (Amount 1, 2, etc.) has changed, so before I go any further I want to be sure I have the most current requirements. Thanks.
-
Re: Code to insert fields onto existing worksheet
OK I will show all the columns needed. Thanks again
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
Please find attached example. The first sheet in an example of the original data format (BEFORE) and the second sheet (AFTER) of how the new format of the data should be. Don't need to keep the original format so it can be overwritten with the new format on the same sheet. As mentioned in earlier posts there will be multiple sheets so the code will need to loop through all the sheets. I hope this helps. Thanks again.
-
Re: Code to insert fields onto existing worksheet
Hi vbfbryce did you get a chance to check the example to see if this is something that can be done? Thanks
-
Re: Code to insert fields onto existing worksheet
it can definitely be done, but i won't have the time to do it. each change in reqs takes a fair amount of time to sort through, especially when things like "where the first column of data is" are changed. i think you should be able to use the examples i've given and try to modify to fit your latest changed requirements, but i can't give you the complete solution again.
give it a shot, let us know where you stumble.
-
Re: Code to insert fields onto existing worksheet
I will try to do it. Are you able to help me with the code for splitting the report into the three sections as in the example so I have all the codes listed in the rows and then the three splits across the columns to start me off please?
-
Re: Code to insert fields onto existing worksheet
Will detail the steps, but not the code:
1) Find the beginning and the end of the top section (can't remember if it's income or expenditures).
2) Add the columns to the right of that region (like we've already done).
3) Find the beginning and the end of the bottom section.
4) Copy that region to the next available columns.
5) Add the other columns to the right of it.
There are examples in the "current code" that should show the general idea for each step.
-
Re: Code to insert fields onto existing worksheet
Thanks again. That's the bit I'm not sure about the code I need to find the top and end of the top section, the start of the middle and end of middle etc. The top part will say Expenditure 1 and the start of the middle part will say Expenditure 2 and the start of the bottom part will say Income but I'm not sure how to code this. You have already helped me a lot and would really appreciate your help on this part. Thanks
-
Re: Code to insert fields onto existing worksheet
Use some sample data blocks, one starting in A4, the other starting a couple rows below the bottom of the first block, and step through this, watching the values of the variables as you do:
Code:
Sub findStartEnd()
Dim ws As Worksheet
Dim startTop As Integer
Dim endTop As Integer
Dim startBottom As Integer
Dim endBottom As Integer
Set ws = ActiveSheet
stop
startTop = 4 'if the first row of data will ALWAYS be row 4
endrow = ws.Range("a" & startTop).End(xlDown).Row 'this is the equivalent of having cell A4 selected, then hitting CTRL+Down (the down arrow)
'that takes you to the last filled cell in that column
MsgBox "Start row is: " & startTop & ", End row is: " & endTop
'then do the same thing for the "bottom section," figuring out where to start (ie. 2 rows below the word "Income" or something like that)
Set ws = Nothing
End Sub
-
Re: Code to insert fields onto existing worksheet
Thanks for the code. I tried it and I get compile error variable not defined on
Code:
endrow = ws.Range("a" & startTop).End(xlDown).Row
-
1 Attachment(s)
Re: Code to insert fields onto existing worksheet
I'm attaching the sheet with the code. Thanks
-
Re: Code to insert fields onto existing worksheet
Gave you a bad line, should have been "endTop=..." not "endrow=..."
Look at the variables which are dimmed at the beginning and compare to the offending line when that happens.
-
Re: Code to insert fields onto existing worksheet
Thanks. Sorry I need to pay more attention to the code.
Each time the length of the reports will vary so how will that affect the code?
-
Re: Code to insert fields onto existing worksheet
The intent of that kind of code is specifically to be able to handle ranges of varying size. Test it out manually by creating 2 or 3 different sized ranges, then starting in the upper left corner of each in turn, and hitting CTRL+Down.
-
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.
