I have two columns A and B with numbers as values.
In C1 I want =A1 + B1
In C2 I want =A2 + B2
and so on. I have written the following VBA code - while it works it adds "0" after the end of the last row in range.
Let's assume my last row is A10. It adds "0" in C11 when I run the code.
How do I prevent this?
Sub macro()
Dim R As Long
R = 1
Do
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop Until IsEmpty(ActiveCell.Offset(0, -2))
End Sub
Just replace your Until condition to the following string:
Loop Until IsEmpty(ActiveCell.Offset(1, -2))
That will check the right cell for being empty. The rest of your code should remain intact.
Take a look at Do Until and Do While and While.
If you really want to iterate over cells you may go ahead. But here a method using Arrays, this will by all means reduces any performance drops that you would get looping over cells...
Option Explicit
Sub AddToRigh()
Dim i As Integer
Dim vArr As Variant
Dim LastRow As Long
'--assume you are working on Sheet 1
LastRow = Sheets(1).Cells(Rows.Count, Range("A1").Column).End(xlUp).Row
ReDim vArr(1 To LastRow)
For i = LBound(vArr) To UBound(vArr)
vArr(i) = "=Sum(RC[-2]:RC[-1])"
Next i
'--output this entire array with formulas into column C
Sheets(1).Range("C1").Resize(UBound(vArr)) = Application.Transpose(vArr)
End Sub
Output:
I'm by no means an expert in vba, but you could do this:
Sub macro()
Dim R As Long
R = 1
Do While Not IsEmpty(ActiveCell.Offset(0, -2))
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop
End Sub
I thought I'd recommend a slightly different course of action, just to give you ideas :):
Sub macro()
Dim found As Range
Set found = Range("A:A").Find("*", after:=Range("A1"), searchdirection:=xlPrevious)
If Not found Is Nothing Then
Range(Range("A1"), found).Offset(0, 2).FormulaR1C1 = "=RC[-2]+RC[-1]"
End If
End Sub
Related
I'm trying to clean up some data in a column in Excel but it has too many rows to do it manually and the data I want is mixed up with irrelevant values.
Essentially, I need a VBA macro to search each cell in column A of Sheet1 for any row that contains the partial string "SAAM" and then copy both the full string attached to it and the next row of data directly underneath each instance to a separate sheet (Sheet2).
I expect the output to show what is shown in the attached image. I put the expected result in column B for clarity but I really want it in Sheet2 Column A.
My script currently ends up moving the full contents of the cell to Sheet2.
Sub Test()
For Each Cell In Sheets(1).Range("A:A")
If InStr(Cell.Value, "SAAM") > 0 Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow + 1).Select
Selection.Copy
lastRow = ActiveSheet.UsedRange.Rows.Count
If lastRow > 1 Then lastRow = lastRow + 1
ActiveSheet.Range("B" & lastRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next
End Sub
Something like this (note this was based on looking at your code, not at the screenshot, which tells a different story...)
Sub Test()
For Each Cell In Sheets(1).UsedRange.Columns(1).Cells
If Not IsError(Cell.Value) Then
If InStr(Cell.Value, "SAAM") > 0 Then
'copy to first empty row
Cell.Resize(2,1).Entirerow.copy _
Sheets(2).Cells(rows.count, 1).end(xlup).offset(1,0)
End If 'has substring
End If 'not error
Next
End Sub
Edit: seem like you want something more like this, based on your screenshot (untested)
Sub Test()
Dim arr, i as long, sep
For Each Cell In Sheets(1).UsedRange.Columns(1).Cells
If Not IsError(Cell.Value) Then
If InStr(Cell.Value, "SAAM") > 0 Then
arr = Split(Cell.Value, vbLf) 'split cell content on newline
sep = ""
For i = lbound(arr) to ubound(arr)-1
if arr(i) like "*SAAM*" then
with cell.offset(0, 1)
.value = .value & sep & arr(i) & vbLf & arr(i+1)
sep = vbLf & vbLf
end with
end if
Next i
End If 'has substring
End If 'not error
Next
End Sub
Based on your code I’ll modify it this way:
Sub Test()
For Each Cell In Sheets(1).Range("A:A")
If InStr(Cell.Value, "SAAM") > 0 Then
matchRow = Cell.Row
Sheets(1).Cells(matchRow,1).Copy
lastRow = Sheets(2).Cells(Rows.Count,1).End(xlUp).Row + 1
Sheets(2).Range("B" & lastRow).Select
Sheets(2).PasteSpecial Paste:=xlPasteValues
Sheets(1).Select
End If
Next
End Sub
So data gets pasted in to column B as the code keeps running it'll do a condition check to see there's any values in column B and paste a value in to the adjacent column A. I need to make it so it does two condition checks:
If there's values in column b, but then to check if there's values in column A before pasting so it doesn't overwrite different data that's been pasted already.
For Each Cell In y.Sheets("Compiled").Range("A:B")
If Range("B:B").Value <> "" And Range("A:A").Value = "" Then
Cell.Offset(0, -1).PasteSpecial xlPasteValues
End If
Next
You were close, don't try to loop over a multiple column range:
Sub Test()
For Each Cell In y.Sheets("Compiled").Range("B:B")
If Cell.Value <> "" And Cell.Offset(0, -1).Value = "" Then
Cell.Offset(0, -1).Value = Cell.Value
End If
Next
End Sub
NOTE: You are looping through every cell in Range("B:B") which is probably unnecessary. It'd be better if you use a lastrow value, or a static range like Range("B2:B1000"). Or you could use a criteria to exit your loop like If Cell.Value = "" Then Exit For.
Here's a version of the code that implements the lastrow value that dwirony mentioned in their answer. This also throws everything in arrays, so it might go a bit faster if you have a really large dataset.
Option Explicit
Sub test()
Dim ACol As Variant
Dim BCol As Variant
Dim lastrow As Long
Dim i As Long
lastrow = Range("B:B").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).row
BCol = Range("B1:B" & lastrow).Value
ACol = Range("A1:A" & lastrow).Value
For i = LBound(BCol) To UBound(BCol)
If IsEmpty(ACol(i, 1)) And Not IsEmpty(BCol(i, 1)) Then
ACol(i, 1) = BCol(i, 1)
End If
Next i
Range("A1:A" & lastrow).Value = ACol
End Sub
basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.
In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.
Ths is my current code:
Sub texttocolumns()
Dim rng As Range
Dim x As Integer
x = ActiveSheet.UsedRange.Rows.Count
For i = x - 2 To 1
Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True
k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")
Cells(2 + i, 1).Rows(k).Insert
Next i
End Sub
I can't find my mistake at the moment, could someone please help me out? thanks!
Since the output result is posted to a different location the expensive task of inserting rows can be avoided.
Try this procedure, which also avoids working with the source range by generating from it two Arrays:
An array containing the fixed fields
An array containing the field that needs to be split
The Procedure:
Sub Range_Split_A_Field()
Dim wsTrg As Worksheet, rgOutput As Range
Dim aFld_1To5 As Variant, aFld_6 As Variant
Dim aFld As Variant
Dim lRow As Long, L As Long
lRow = 3
Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
Application.Goto wsTrg.Cells(1), 1
With wsTrg.Cells(lRow, 1).CurrentRegion
Set rgOutput = .Rows(1).Offset(0, 10)
.Rows(1).Copy
rgOutput.PasteSpecial
Application.CutCopyMode = False
aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
End With
lRow = 1
For L = 1 To UBound(aFld_1To5)
aFld = aFld_6(L, 1)
If aFld = vbNullString Then
rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
lRow = 1 + lRow
Else
aFld = Split(aFld, Chr(44))
aFld = WorksheetFunction.Transpose(aFld)
rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
lRow = lRow + UBound(aFld)
End If: Next
End Sub
Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)
Would something like this work:
'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G
'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15
Sub Test()
TextToColumns Sheet1.Range("A1")
TextToColumns Sheet1.Range("A9"), "!"
End Sub
Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")
Dim rng As Range
Dim lCount As Long
Dim x As Long
'How many delimiters in target string?
lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))
'Add the blank rows.
For x = 1 To lCount + 1
Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next x
'Split the string.
Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter
'Use TRANSPOSE formula to paste to rows and then remove formula.
With Target.Offset(1).Resize(lCount + 1, 1)
.FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
.Value = .Value
End With
'Delete the original text string.
Target.EntireRow.Delete
End Sub
Edit:
To use from the Macro dialog box you could add this small procedure:
Public Sub Test()
Dim y As Long
y = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet
For y = 5 To 1 Step -1
TextToColumns .Cells(y, 1)
Next y
End With
End Sub
Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA
I am trying to add vlookup formulas to multiple columns (E:I) when the corresponding cell in column "D" is blank. For example when cell D113 and down are blank, I want to add "=VLOOKUP(A2,Sheet4!$A:$L,5,False)" to cells E113:and down and then repeat for colums G,H,I,etc.
But the code I have now as shown below adds the vlookup to all cells in column E & lastrow, overwriting existing data above E113. Code is as follows:
Sub PrevInactives()
Dim ws As Worksheet
Dim lastrow As Long
lastrow = Range("A2").End(xlDown).Row
For Each Cell In Sheets(1).Range("D2:D" & lastrow)
Select Case Cell.Value
Case ""
If Cell.Offset(1, 0) = "" Then
Range("E2:E" & lastrow).Formula = "=VLOOKUP(A2,Sheet3!$A:$L,5,FALSE)"
End If
End Select
Next Cell
End Sub
Does anyone have a solution for my dilemma?
Thanks,
Jason
EDIT, 9/26/17: Below is the updated code I added in, but when I run this macro, nothing happens.
Sub PrevInactives()
Dim r As Long
For r = 2 To lastrow
lastrow = Range("A2").End(xlDown).Row
If IsEmpty(Cells(r, 4).Value) And Not IsEmpty(Cells(r - 1, 4).Value) Then
Range(Cells(r, 5), Cells(r, 9)).Formula = "=VLOOKUP($A2" & r & ",Sheet4!$A:$L,False)"
End If
Next r
End Sub
If I'm understanding correctly, you want to have inside of your loop something such as:
If IsEmpty(Cells(r,4).Value) AND Not IsEmpty(Cells(r-1,4).Value) Then
'Insert vlookup stuffs
End If
Rather than using For Each as the loop, you can loop For r = 2 to LR using the above example:
Dim r as Long
For r = 2 to lastrow
If IsEmpty(Cells(r,4).Value) AND Not IsEmpty(Cells(r-1,4).Value) Then
Range(Cells(r,5),Cells(r,9)).Formula= "=VLOOKUP($A" & r & ",Sheet3!$A:$L,5,FALSE)"
End If
Next r
Essentially, the issue is that you are using:
Range("E2:E" & lastrow).Formula = "=VLOOKUP(A2,Sheet3!$A:$L,5,FALSE)"
When you want Cell.Formula = ""; you are adding the formula to all of those cells if the case is ever true.
Edit, 20170926:
Fixing your code:
Sub PrevInactives()
Dim r As Long, lastrow as Long
lastrow = Range("A2").End(xlDown).Row 'Need to define before looping
'You could use lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To lastrow
If IsEmpty(Cells(r, 4).Value) And Not IsEmpty(Cells(r - 1, 4).Value) Then
Range(Cells(r, 5), Cells(r, 9)).Formula = "=VLOOKUP($A" & r & ",Sheet4!$A:$L,False)" 'You had in A2&r, so it would be A22, A23, ..., A2&LR
End If
Next r
End Sub
I have a column of data in excel. I want to loop through the data and combine the contents into a single string. I can specify the cell range, but what if the range is unknown. I want to be able to loop until the cell becomes empty. here is what I have so far.
Sub ConcatenationLoop()
Dim rng As Range, i As Integer
Set rng = Range("A1", "A5")
For i = 1 To rng.Rows.Count
With Range("B1")
If .Value = "" Then
.Value = rng.Range("A" & i)
Else
.Value = .Value & ", " & rng.Range("A" & i)
End If
End With
Next
is it possible to combine with something like:
Do Until IsEmpty(ActiveCell)
Much help is appreciated!
End Sub
With Worksheets("YourSheetName")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Loop it to LastRow.
Get the first empty cell from the top using
lLastRow = sheet.Cells(1, 2).End(xlDown).Row
The use this in your for loop
For i = 1 To lLastRow
You could use the following skeleton:
Sub ALoop()
Dim r As Long
r = 2 '//Start row
While Len(Cells(r, "A")) > 0 '//Or While Not IsEmpty(...)
'// Your code
r = r + 1 '//Don't forget to increment row
Wend
End Sub