Sum columns in a new column next to the selection - vba

I'm trying to sum a number of columns together in a new column.
I have been able to get to the point where I take A+B and place the values in C. However, the actual columns I will need to sum vary. Is there a way I can edit my code so that any selected columns can be summed in a new column to the right of the selection?
For example. If I select columns B-D, it would insert a new column in E that houses the sums of columns B,C, and D. Or if I selected E-F, it would insert a new column in G that houses the sums of columns E and F.
Sub SumColumns()
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
For i = 1 To Lastrow
Range("C" & i).Value = Range("A" & i).Value + Range("B" & i).Value
Next i
End Sub

Here is my (rather sloppy) solution:
Sub Test()
Dim col1 As String, col2 As String, lastrow As Long
col1 = Split(Selection.Address, "$")(1)
col2 = Split(Selection.Address, "$")(3)
lastrow = Cells(Rows.Count, col2).End(xlUp).Row
Columns(col2 & ":" & col2).Offset(0, 1).Insert Shift:=xlToRight
For i = 1 To lastrow
Range(col2 & i).Offset(0, 1).Value = WorksheetFunction.Sum(Range(col1 & i & ":" & col2 & i))
Next i
End Sub
I say this is sloppy, because if you have the entire column selected, you won't Split out the column values appropriately. So it depends on how you're trying to do this.

This procedure will let you select any range. It will add a column at the end of the range and sum each row to the new column.
Sub test()
Call InsertSumCol(Sheet1.Range("B2:E4"))
Call InsertSumCol(Sheet2.Range("E1:F3"))
End Sub
Private Sub InsertSumCol(ByVal oRange As Range)
'Add Sum Column to end of Range
oRange.Worksheet.Columns(oRange.Column + oRange.Columns.Count).Insert shift:=xlToRight
' Sum Each Row in Range
Dim oRow As Range
For Each oRow In oRange.Rows
oRow.Cells(1, oRow.Columns.Count + 1) = WorksheetFunction.Sum(oRow)
Next
End Sub

I assume that you want to sum vertically all cells in a row starting from column A.
Try this (some tips and comments are in code):
'use this in order to avoid errors
Option Explicit
Sub SumColumns()
'always declare variables!
Dim LastRow As Long, i As Long, ws As Worksheet, lastCol As Long, firstCol As Long
'if you can, avoid using ActiveSheet, Selection, etc. it's prone to errors
Set ws = ActiveSheet
i = 1
Do
firstCol = ws.Cells(i, 1).End(xlToRight).Column
lastCol = ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column
'there isn't any filled cells in a row
If lastCol = 1 Then Exit Do
ws.Cells(i, lastCol + 1).Value = Application.WorksheetFunction.Sum(ws.Range(ws.Cells(i, firstCol), ws.Cells(i, lastCol)))
i = i + 1
Loop While True
End Sub
Before and after:

Related

Delete Blank Rows from Column B

I am trying delete all rows where column B to AD (Lastrow) are blank. On my excel sheet every couple of rows or so column B to AD are blank so i am trying to delete those rows. I have been trying to use the below code:
Sub T()
Dim rng As Range
Set rng = Range("B1:AC10402")
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
No success
Try this code:
Sub DeleteBlankRows()
Dim i As Long
Dim lastRow As Long: lastRow = 10 'here you have to specify last row your table uses
For i = lastRow To 1 Step -1
If Cells(i, Columns.Count).End(xlToLeft).Column = 1 Then
Rows(i).Delete
End If
Next i
End Sub
Little explanation
You specified that you need check for emptiness within row, columns B through AD. This piece of code Cells(i, Columns.Count).End(xlToLeft).Column will return column of the right-most (starting from first column), non-empty cell. If whole row is empty or there's data in first column - it will return 1 - which is misleading, when you are considering A cloumn. But it isn't here, since we consider columns starting with B. So if it returns 1, it means that the row is empty and should be deleted.
this deletes all blank rows in column B
Dim LastRow, i As Integer
LastRow = activesheet.Cells(activesheet.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
If WorksheetFunction.CountA(Range("B" & i)) = 0 Then
Range("B" & i).EntireRow.Delete
End If
Next i
this deletes all blank rows if column B to column AC is blank
Dim LastRow, i As Integer
LastRow = activesheet.Cells(activesheet.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
If WorksheetFunction.CountA(Range("B" & i & ":" & "AC" & i)) = 0 Then
Range("B" & i & ":" & "AC" & i).EntireRow.Delete
End If
Next i

How to select last three row automatically on a give range in EXCEL VBA

I created a code to select and paste data from one sheet to another. But this code is always selecting last three values in row.
I need to select the data based on given range. Eg C5:C15 not for the entire c column. Help me
Private Sub CommandButton1_Click()
Dim LastRow1, LastRow2, LastRow3 As Long
Dim Last3Rows1, Last3Rows2, Last3Rows3 As Range
LastRow3 = Sheets("AVG-PO").Range("C" & Rows.Count).End(xlUp).Row
LastRow1 = Sheets("AVG-PO").Range("A" & LastRow3).End(xlUp).Row
LastRow2 = Sheets("AVG-PO").Range("B" & LastRow3).End(xlUp).Row
Set Last3Rows3 = Sheets("AVG-PO").Range("C" & LastRow3).Offset(-2, 0).Resize(3, 1)
Set Last3Rows1 = Sheets("AVG-PO").Range("A" & LastRow3).Offset(-2, 0).Resize(3, 1)
Set Last3Rows2 = Sheets("AVG-PO").Range("B" & LastRow3).Offset(-2, 0).Resize(3, 1)
Last3Rows1.Select
Selection.Copy Sheets("Data").Range("A30")
Last3Rows2.Select
Selection.Copy Sheets("Data").Range("B30")
Last3Rows3.Select
Selection.Copy Sheets("Data").Range("C30")
End Sub
Not sure i quite understand what range you want but you might be able to use this.
Sub test()
Dim NextFree As Long
Dim TableStartRange As Long
For i = 1 To 100
Select Case Range("A" & i).Value
Case "Table1"
TableStartRange = i + 1 'finds table1 in A2 and then +1 before the actual table start in column C
End Select
NextFree = Range("C" & TableStartRange & ":C" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row ' returns the value 14 since its the first free row in column C
End Sub

EXCEL VBA: looping through columns and copying

In excel I have four columns. There are numbers in the first column, the second column is blank, the third also contains numbers and the fourth contains text.
I want to check each value in the first column and check if it exists in the third column. If it does the value in the fourth column next to the corresponding third column should be copied up to the second column next to the corresponding first column.
I am getting the error compile error. Next without For. Here is my code so far:
Sub Compare()
Dim colA As Integer, colB As Integer
colA = Columns("A:A").Rows.Count
colB = Columns("C:C").Rows.Count
For I = 2 To colA 'loop through column A
For j = 2 To colB 'loop through column C
' If a match is found:
If Worksheets("Sheet1").Cells(I, 1) = Workshee("Sheet1").Cells(j, 3) Then
' Copy
Worksheets("Sheet1").Cells(j, 4) = Worksheets("Sheet1").Cells(I, 2)
'Exit For
Next j
Next I
End Sub
As already pointed out in the comments above you could also accomplish this with a VLookUp or a combination of INDEX/MATCH. Yet, if you wish to stick with VBA then you should adjust your code a bit.
Option Explicit
Sub Compare()
Dim ws As Worksheet
Dim i As Long, j As Long
Dim colA As Long, colC As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
colA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
colC = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
'loop through column A
For i = 2 To colA
'loop through column C
For j = 2 To colC
' If a match is found:
If ws.Cells(i, 1).Value2 = ws.Cells(j, 3).Value2 Then
' Copy column B to Column D as written in your code above
ws.Cells(j, 4).Value2 = ws.Cells(i, 2).Value2
' or copy column D to Column B as written in the question / post
ws.Cells(i, 2).Value2 = ws.Cells(j, 4).Value2
'Exit For
End If
Next j
Next i
ws.Range("D2:D" & colC).FormulaR1C1 = "=INDEX(R2C2:R" & colA & "C2,MATCH(RC[-1],R2C1:R" & colA & "C1,0))"
End Sub
The above code will do both:
the VBA way and
write the INDEX/MATCH formulas for you.
Just delete the code segment you don't want.
If you insist on using your code, then use this fixed version. It should work fine though it's untested.
Sub Compare()
Dim LastRowA As Long, LastRowB As Long, i As Long, j As Long
With Worksheets("Sheet1")
LastRowA = .Range("A" & Rows.Count).End(xlUp).Row
LastRowC = .Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To LastRowA
For j = 2 To LastRowC
If .Cells(i, 1) = .Cells(j, 3) Then .Cells(i, 2) = .Cells(j, 4): Exit For
Next j
Next i
End With
End Sub
Let me know in the comment section if there's any error.

VBA - put value in each empty row created

I have a vba code that creates empty row after each row with value:
Row 1
Row 2
Row 3
Output
Row 1
Row 2
Row 3
In the empty rows I want to insert value "check1", "check2", the auto increment of "check" and "autonumber"
To get a final output of the below:
Row 1
check1
row 2
check2
row n
check n
here is the code I have started:
Sub Insert_Blank_Rows()
'Select last row in worksheet.
Selection.End(xlDown).Select
Do Until ActiveCell.Row = 1
'Insert blank row.
ActiveCell.EntireRow.Insert shift:=xlDown
'Move up one row.
ActiveCell.Offset(-1, 0).Select
Loop
End Sub
Here's a quick and easy and efficient way with only minimal adjustment to your current code.
Sub Insert_Blank_Rows()
Dim rng as Range
Set rng = Selection ' grab top most cell in range, you may want to actually refer to the actual cell.
rng.End(xlDown).Select 'Select last row in worksheet.
Do Until ActiveCell.Row = 1
'Insert blank row.
ActiveCell.EntireRow.Insert shift:=xlDown
'Move up one row.
ActiveCell.Offset(-1, 0).Select
Loop
'fill blanks with incremental checks
Dim rngBottom as Range
Set rngBottom = Cells(rows.Count,rng.Column).End(xlUp).Offset(1)
Range(rng, rngBottom).SpecialCells(xlCellTypBlanks).FormulaR1C1 = "=""Check""&ROW()/2"
End Sub
I'll throw in this solution, with no looping nor inserting
it's very fast (less than 1 second for 20k rows)
Option Explicit
Sub main()
Dim helperCol As Range
With ActiveSheet.UsedRange
Set helperCol = .Columns(.Columns.Count + 1)
End With
With Range(ActiveCell, ActiveCell.End(xlDown))
.Offset(, helperCol.Column - .Column).Formula = "=ROW()"
With .Offset(.Rows.Count)
.Formula = "=CONCATENATE(""check"",ROW()-" & .Rows.Count & ")"
.Value = .Value
With .Offset(, helperCol.Column - .Column)
.Formula = "=ROW()-" & .Rows.Count & "+ 0.1"
.Value = .Value
End With
End With
.Resize(2 * .Rows.Count, helperCol.Column - .Column + 1).Sort Key1:=helperCol.Resize(2 * .Rows.Count), Header:=xlNo
helperCol.Resize(2 * .Rows.Count).Clear
End With
End Sub
as per OP's request, it takes move from ActiveCell
So every other row is empty and you want to fill it? One way would be something like
finalRow = cells(1000000,1).end(xlup).row
yourIncrement = 1
for i = 1 to finalRow
if isempty(cells(i,1)) then
cells(i,1) = "check" & yourIncrement
yourIncrement = yourIncrement + 1
end if
next i
I am assuming your want to fill column 1 (A).
How's this?
Sub Insert_Blank_Rows()
Dim lastRow&, i&
'Assuming column A has the most data (if not change the `1` to whatever column # does have the most data
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
'Select last row in worksheet.
'Selection.End(xlDown).Select ' Don't use `.Select`
i = 2
Do While i <= lastRow
Rows(i).Select
Rows(i).EntireRow.Insert shift:=xlDown
Cells(i, 1).Value = "Check " & Cells(i - 1, 1).Value
Cells(i, 1).Value = Cells(i, 1).Value
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
i = i + 2
Loop
End Sub
Here, I got one for you. I already tested it and work well for requirement.
Which is special in my code? My code will miss no row. Perfect auto-increment.
And I also reference from BruceWayne's code because I don't want to edit his own code.
Sub checkingData()
Dim exeRow As Integer 'For indexing the executing row
Dim lastRow As Integer 'For storing last row
exeRow = 2 'Checking from first row
'Assume that First Column has more data row than Other Column
lastRow = Cells(Rows.Count, 1).End(xlUp).row
'Loop from First Row to Last Row
Do While exeRow <= lastRow + 1
'Select data row
Rows(exeRow).Select
'Insert row below data row
Rows(exeRow).EntireRow.Insert shift:=xlDown
'Set auto-increment result
Cells(exeRow, 1) = "Check " & (exeRow / 2)
'Increase lastRow count because of adding blank row
lastRow = lastRow + 1
'Go to next data row
exeRow = exeRow + 2
Loop
End Sub

Excel-VBA: create named Range in row until end of cell content

Imagine an Excel sheet with some rows and some content in each row (i.e. different column-length for each row).
In Excel-VBA: How can I create a range-X within column-X that goes from row-cell-2 to the end of the content of this X-column ??
i.e. I would like to create a named range per column and each range shall start from row-2 until the end of each column-length!
Thanks for any help on this !
Sure you can use this snippet to find the last filled cell in a column and use that row number to set your range.name - just replace the "A" with whatever column you'd like.
Sub test()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:A" & lastrow).Name = "RangeColA"
End Sub
If you wanted to do it for each column you could try something like this -
Sub test()
Dim lastrow As Integer
Dim letter As String
Dim lastcol As Integer
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 65 To 65 + lastcol
letter = Chr(i)
lastrow = Cells(Rows.Count, letter).End(xlUp).Row
Range(Cells(2, letter), Cells(lastrow, letter)).Name = "RangeCol" & letter
Next
End Sub
Here is another answer (inspired by Raystafarian's answer) that handles the case where the last used cell in the column appears at or above the second row and also gives more flexibility in the name:
Sub NameColumn(Col As String, Optional ColName As Variant)
Dim n As Long
Dim myName As String
If IsMissing(ColName) Then ColName = "Range_" & Col
n = Cells(Rows.Count, Col).End(xlUp).Row
If n <= 2 Then
Range(Col & "2").Name = ColName
Else
Range(Col & "2:" & Col & n).Name = ColName
End If
End Sub
try various things in columns A through E (including leaving a blank column) then test it like this:
Sub test()
NameColumn "A"
NameColumn "B"
NameColumn "C"
NameColumn "D", "Bob"
NameColumn "E"
End Sub