Skip a row, start sum process again - excel

I have a report generated from a program that opens in excel similar to the image below
I have been using this code to sum the amounts:
Sub SumTotals()
lastrow = Sheets("sheet1").Cells(Rows.Count, 2).End(xlUp).Row
Range("b" & lastrow + 1) = WorksheetFunction.Sum(Sheets("sheet1").Range("b2:b" & lastrow))
Range("a" & lastrow + 1) = Cells(1, 1)
Range("a1:b" & lastrow).Select
Selection.Delete Shift:=xlUp
End Sub
The issue I am running into is that the code sums both company A and company B and the ends up
Company A 5,625.07
What I am trying to accomplish is
Company A 2,053.73
Company B 3,571.34
When I get these reports there is generally 100 + companies so if I can speed up the process it would be very beneficially.
I suspect the first line of code is the problem
lastrow = Sheets("sheet1").Cells(Rows.Count, 2).End(xlUp).Row
As this is placing the end at cell B8 instead of B3. I am trying to figure out how to sum the first column of numbers until the first blank row, and then carry on to the numbers below and carry out the same process. Any suggestions are appreciated.
ideal end result
Ideal result

Try this
Sub x()
Dim r As Range
For Each r In Columns(2).SpecialCells(xlCellTypeConstants).Areas
r(r.Count + 1).Value = Application.Sum(r)
r(r.Count + 1).Offset(, -1).Value = r(1).Offset(, -1).Value
r.EntireRow.Delete shift:=xlUp
Next r
End Sub

You can also try this non VBA approach. Enter this formula =IF(A1<>"",SUM(OFFSET(B1,0,0,MIN(IF(B1:B80="",ROW(B1:B80))))),"") in cell C1 to sum all values before blank row. drag formula to the bottom of your values. Since it is an array formula, you must enter it using CTRL+SHIFT+ENTER. You can then filter out blank values in column A to get your result.

Related

How to fix a sum formula that changes ranges

Sub formu
Range(“d” & Rows.count).end(xlUp).offset(2,0).formular1c1 = “=sum(R[-9]c:r[-1]c)”
End sub
Currently this is my formula but it changes on a weekly basis so I t could be R[-14]c:r[-1]c the next week or R[-6]c:r[-1]c the next week. How do I get my formula to change weekly so I don’t have to manually re sum the cell?
Say the following would be your current weeks data:
The following code would add a formula in the cell below the last cell:
Sub formu()
Dim lr As Long
With Formulas
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
.Cells(lr + 1, 4).FormulaR1C1 = "=sum(R[-" & lr & "]c:r[-" & lr - (lr - 1) & "]c)"
End With
End Sub
Whereas the sheet reference is the sheet codename containing the data. Output:
The formula in that cell is currently:
=SUM(R[-10]C:R[-1]C)
You can find a sheet's CodeName in the project explorer and give it a meaningfull name to reference directly :)
First of all, is important to know if your weekly report always put the information in te same order. For example all the numbers start in the Range("A2"). If that the case i recomend you to work whit TagNames. Asuming that the data you need to sum start in the Range("A2")
Dim Col as integer
Dim sRow, eRow as long 's = start, e = end
Col = Range("A2").Column 'Col = 1
sRow = Range("A2").Row 'sRow = 2
eRow = Range("A2").Rnd(xlDown).Row 'eRow = row of the last cell with information to sum
Range(Cells(sRow,Col),Cells(eRow,Col)).Name = "range2Sum" 'Yo assign a tagname
'The you can use what you have done
Range(“d” & Rows.count).end(xlUp).offset(2,0).formula = “=sum(range2Sum)” 'use that tagname that is visible in excel

Filldown columns from cells value in each worksheet

What I am trying to do is to take values from specific cells and make them a filldown column. I have multiple worksheets with different values in them.
This code is working as expected with one worksheet :
Sub Formatting_one()
Range("A12").Value = Range("M6").Value
Range("A12:A" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
End Sub
Then, I started to try the same thing but with looping through worksheets. That's the point I am stuck with. Here is my code for this :
Sub Formatting_many()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.[A1].Resize(, 6).EntireColumn.Insert
ws.Range("A12").Value = ws.Range("M6").Value
ws.Range("A12:A" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
ws.Range("B12").Value = ws.Range("M7").Value
ws.Range("B12:B" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
ws.Range("C12").Value = ws.Range("M8").Value
ws.Range("C12:C" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
ws.Range("D12").Value = ws.Range("I5").Value
ws.Range("D12:D" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
ws.Range("E12").Value = ws.Range("I4").Value
ws.Range("E12:E" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
ws.Range("F12").Value = ws.Range("I6").Value
ws.Range("F12:F" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
ws.Range("G12").Value = ws.Range("I7").Value
ws.Range("G12:G" & Cells(Rows.Count, 7).End(xlUp).Row).FillDown
Next ws
End Sub
I did a step by step, and the result is that the cell is copied in the first cell of the filldown range cells but then it's deleted. Can somebody help ?
The issue …
… is that you look for the last used row in column G
Cells(Rows.Count, 7).End(xlUp).Row
But since you added 6 columns with ws.[A1].Resize(, 6).EntireColumn.Insert column G is now empty, so the last used row is 1
and you actually run
ws.Range("A12:A1").FillDown
which takes the empty cell from A1 and fills it down until A12 (so your inserted value in A12 gets removed).
Solution
After inserting your original column G moved to
ws.Cells(ws.Rows.Count, 7 + 6).End(xlUp).Row

Eliminate duplicates within a range then move the non-blank cells to top of same range, without shifting cells outside the range

The Before image represents educational background that an employee has reported. As you can see, the report that produces the info creates unwanted duplicates and spaces. Can't do anything about that. The After image shows my desired end result. To get there, I manually:
Deleted the duplicates
Copy/pasted the remaining occupied cells to the top of the range without shifting any cells below the range. (Yes, there is data below the range).
How do I automate this with VBA? The Before image represents the range F3:H18 and I've named the range edVal.
This range will always be 3 columns (F-H). The number of rows will vary but I already have code that selects edVal, no matter how many rows it may be.
I have other code doing other stuff elsewhere in the sheet but then I come to this education portion. Assume I've dim'd edVal as Range and edVal is selected. Seems the additional code I need will fit between "With edVal" and End With.
Thanks!
How about something like below, it will remove duplicates and loop through F3 to F18 and if it finds a blank row, it will delete and shift up, but then it will insert a blank row at the bottom, thus leaving your data below the range intact.
Simply adjust the code below with your value from edVal:
Sub foo()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
ws.Range("$F$3:$H$18").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
For i = 3 To 18
If ws.Cells(i, "F").Value = "" Then
ws.Range("F" & i & ":H" & i).Delete Shift:=xlUp
ws.Range("F18:H18").Insert Shift:=xlDown
End If
Next i
End Sub
Adjusting the values for edVal worked as suggested. That code is between the "With edVal / End With" lines. Also shown, as requested by the moderator, is the code I already had.
Sub foo()
Dim empRange as Range, edVal as Range
Dim f as Integer, l as Integer
Set empRange = Range("A3:Z18") 'rows 1 and 2 are headers
With empRange
f = empRange.Row
l = empRange.Rows.Count
Set edVal = Range(.Cells(, 6), .Cells(l, 8)) 'edVal is columns F-H of the larger empRange
With edVal
.RemoveDuplicates Columns:=Array(1, 2, 3), HEADER:=xlNo
For i = f To l + 2 'adding 2 to account for two header rows
If Range("F" & i).Value = "" Then
Range("F" & i & ":" & "H" & i).Delete Shift:=xlUp
Range("F" & l + 2 & ":" & "H" & l + 2).Insert Shift:=xlDown
End If
Next I
End With
End With
End Sub

Rolling Sum in VBA

I am trying to create a rolling twelve month sum in excel using vb. The last column with data is dynamic so I created a variable to store that column number each time. I then tried to create a loop that would output the sum of the previous 12 cells and move to the next cell until it reached 12 calculation cells. But this is not working... Is there something obvious that I am doing wrong?? Thanks!
Sub OSR_ReportComplete()
Dim lCol As Long
Dim p As Integer
lCol = Cells(7, Columns.Count).End(xlToLeft).Column
For p = 0 To 12
Range(Cells(15, lCol - p)).Value = Application.Sum(Range(Cells(7, lCol -
p), Cells(7, lCol - p - 12)))
Next p
End Sub
Could be done in a neater way but this works
Sub OSR_ReportComplete()
Dim lCol As Long
Dim p As Integer
lCol = Cells(7, Columns.Count).End(xlToLeft).Column
For p = 0 To 12
Cells(15, lCol - p) = Application.Sum(Range(Cells(7, lCol - p), Cells(7, lCol - p - 12)))
Next p
End Sub
Also, If your lCol evaluates to a value less then 25 it will fall over though due to trying to reference a column less than 1. I'd recommend using Offset instead
However, a rolling total can be done very easily in excel formulas also. Say your first value is in Column A and your date is in row 1, in row 2 enter in Column A =SUM($A$1:A1) and drag along the rest of your range
Giving:
Formulas:
The following code will generate the formulas above for row 1 in one line instead of doing your loop. This is an example as I don't understand the layout of your sheet from your code
Sub OSR_ReportComplete2()
With Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
.Offset(1, 0).Formula = "=SUM(" & .Cells(1).Address & ":" & Split(.Cells.Address(RowAbsolute:=False, ColumnAbsolute:=False), ":")(0) & ")"
End With
End Sub
This is easier to write in R1C1 notation (however will be displayed in A1 in Excel Sheet)
Sub OSR_ReportComplete2()
With Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
.Offset(1, 0).FormulaR1C1 = "=SUM(" & .Cells(1).Address(ReferenceStyle:=False) & ":R[-1]C)"
End With
End Sub
First of all, I suggest you don't use VBA for this. Instead, use the inbuilt OFFSET function, like this.
Your code is quite complex, but maybe you should be using xlToRight instead of xlToLeft to find the last column.
If you want to use VBA, you can try using WorkSheetFunction.offset, putting it into a range variable and then summing that range.

Excel - copying text from one cell to another without deleting original content

Basically I have the following scenareo:
2 columns, with 600 rows of data.
I need to copy the data from column 2 and place it at the end of the content in column1 for the same rows. This would result in column 1 having its original content plus the additional content of column 2.
Any information in how I can do this will be greatly appreciated.
Thanks in advance!
Here's a VBA in a simple form. Just create a macro, add these lines to it. Then select your original column (what you're calling column 1), and run the macro.
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
The bracketed cell reference is a relative statement - 1, 2 means "same row, one column to the right" so you can change that if you need. You could make it loop by expanding thusly:
Do
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
Exit Do
End If
Loop
That loop will carry on until it finds a blank cell, then it'll stop. So make sure you have a blank cell where you want to stop. You could also add extra characters into the line that combines.. so in the above example it's ActiveCell.Value = a + b, but you could make it ActiveCell.Value = a + " - " + b or anything else that may help.
This should take the values from column 2 and place them sequentially at the bottom of column 1.
Sub test()
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Dim r As Long
Set rng1 = Range("A1", Range("A1048576").End(xlUp))
Set rng2 = Range("B1", Range("B1048576").End(xlUp))
r = rng1.Rows.Count + 1
For Each cl In rng2
Cells(r, 1).Value = cl.Value
r = r + 1
Next
End Sub
Just keep it simple. Here is the code.
Sub copyCol()
Dim lastRow As Long
lastRow = Range("A65000").End(xlUp).Row
Range("B1:B" & lasrow).Copy Range("A" & lastRow).Offset(1, 0)
End Sub
As this question received a number of views (10,000+) I thought it was important to also share another and far simpler solution:
In cell C1 use the formula:
=(A1 & B1)
This will copy the content of cell A1 and B1 into cell C1. Drag the formula to all other rows (row 600 in my case).
Then copy the column and paste using 'values only'.
You will then have cells in column C containing the content of column A and column B in a single cell on a row-to-row basis.

Resources