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
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.
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.
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
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...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.
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.
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.
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 ***
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
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
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
Hi I want to end up with the "After" but the start will be like this
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
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.
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.
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.
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?
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
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
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.