I am trying to get a faster and more efficient code than this one, as range will increase a lot over time, so I will need to substitute For Each.
The macro would look up the value "Monday" through each cell of a column and, if found, it would return the value "Substract" in the preceding cell in column A.
Sub ForEachTest()
Dim Rng As Range
Set Rng = Range("B3:B1000")
For Each cell In Rng
If cell.Value = "Monday" Then
cell.Offset(0, -1) = "Substract"
End If
Next cell
End Sub
Loop within VBA rather than on the worksheet:
Sub faster()
Dim arr()
arr = Range("A3:B1000")
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 2) = "Monday" Then arr(i, 1) = "Substract"
Next i
Range("A3:B1000") = arr
End Sub
EDIT#1:
This version addresses BigBen's concern that column B should not be overwritten so as to preserve any formulas in that column. Only column A is overwritten here:
Sub faster2()
Dim arr(), brr()
arr = Range("A3:A1000")
brr = Range("B3:B1000")
For i = LBound(brr, 1) To UBound(brr, 1)
If brr(i, 1) = "Monday" Then arr(i, 1) = "Substract"
Next i
Range("A3:A1000") = arr
End Sub
You can avoid the loop by filtering your data and working with the resulting visible set of data.
This will only modify the cells in Column A when Column B = Monday. All other cells remain as-is
Sub Shelter_In_Place()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
lr As Long
lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws.Range("A1:B" & lr).AutoFilter Field:=2, Criteria1:="Monday"
ws.Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).Value = "Subtract"
ws.AutoFilterMode = False
End Sub
Try using Evaluate
Sub Test()
With Range("A3:A" & Cells(Rows.Count, 2).End(xlUp).Row)
.Value = Evaluate("IF(" & .Offset(, 1).Address & "=""Monday"",""Substract"","""")")
End With
End Sub
Related
I am trying to have a macro auto-sum the bottom of column L each time I run it while it takes into account that the length of the column varies. I had this code that auto-summed the bottom of a column G, so I switched the G to an L but it is not working as intended. Why is that? Could someone please make an edit to the code so it automatically sums the bottom of column even though the range may vary weekly?
Sheets("Report").Select
Const SourceRange = "A:L"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
c = NumRange.Count
Next NumRange
This would add a SUM total at the bottom of each column between A & L.
Public Sub Add_Total()
Dim ColumnNumber As Long
Dim LastRow As Long
With ThisWorkbook.Worksheets("Report")
For ColumnNumber = 1 To 12
LastRow = .Cells(.Rows.Count, ColumnNumber).End(xlUp).Row
With .Cells(LastRow + 1, ColumnNumber)
.FormulaR1C1 = "=SUM(R2C:R[-1]C)"
.Font.Bold = True
End With
Next ColumnNumber
End With
End Sub
To add it to just column L you could change the code to:
Public Sub Add_Total1()
Dim LastRow As Long
With ThisWorkbook.Worksheets("Report")
LastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
With .Cells(LastRow + 1, 12)
.FormulaR1C1 = "=SUM(R2C:R[-1]C)"
.Font.Bold = True
End With
End With
End Sub
I don't have enough reputation yet to add a comment to reply to your question to Darren - but all you have to do is delete the whole line with "Next" in it from his second set of code; it was the end of the "for" loop that he removed from his first set of code and should have been deleted.
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
I have data where I have many column headers. One of the header is "Text" and one other header is "Value Date". I want to combine the values contained in every row between these columns in another column row-wise.
The problem is the number of columns between these two headers is not constant. It changes with every new ledger I export. So I want my code to be dynamic in such a way that it will identify the column of "Text" and then it will identify the column of "Value Date" and combine everything between in another column row-wise.
This is where I have reached with my code but I don't know why it's not working. I have been trying this for last 3 days only to get nowhere. When I run this code, the result which I get is "TextColumnNo:ValueColumnNo".
Sub TextJoin()
Dim TextColumnNo As Range
Dim ValueColumnNo As Range
Range("A1").Select
ActiveCell.EntireRow.Find("Text").Activate
Set TextColumnNo = Range(ActiveCell.Address(False, False))
Range("A1").Select
ActiveCell.EntireRow.Find("Value").Activate
Set ValueColumnNo = Range(ActiveCell.Address(False, False))
ActiveCell.Offset(1, -1).Select
Application.CutCopyMode = False
ActiveCell.Value = Application.WorksheetFunction.TextJoin(" ", True, _
"TextColumnNo:ValueColumnNo")
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A8524")
ActiveCell.Range("A1:A8524").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
You would need 2 loops for this. One looping through all rows and one looping through the columns to combine the text for each row.
Note that you need to adjust some things like sheet name and output column here.
Option Explicit
Public Sub TextJoin()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1") 'define a worksheet
'find start
Dim FindStart As Range
Set FindStart = ws.Rows(1).Find("Text")
If FindStart Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find end
Dim FindEnd As Range
Set FindEnd = ws.Rows(1).Find("Value Date")
If FindEnd Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find last used row in column A
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 2 To lRow 'loop through all rows (2 to last used row)
Dim CombinedText As String
CombinedText = vbNullString 'initialize/reset variable
Dim iCol As Long 'loop through columns for each row (from start to end column)
For iCol = FindStart.Column To FindEnd.Column
CombinedText = CombinedText & ":" & ws.Cells(iRow, iCol).Text 'combine values
Next iCol
ws.Range("Z" & iRow) = CombinedText 'write values in column Z
Next iRow
End Sub
Sub TextJoin()
Dim ColRefText As Long
Dim ColRefValueDate As Long
Const firstcol = "Text"
Const secondcol = "Value Date"
Dim r As Range
Set r = Rows(1).Cells.Find(firstcol)
If Not r Is Nothing Then
ColRefText = r.Column
Set r = Rows(1).Cells.Find(secondcol)
If Not r Is Nothing Then
ColRefValueDate = r.Column
End If
End If
If ColRefValueDate + ColRefText > 0 Then
With Cells(2, Worksheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
.Formula = Replace("=" & Cells(2, ColRefText).AddressLocal & "&" & Cells(2, ColRefValueDate).AddressLocal, "$", "")
.Copy Range(.Address, Cells(ActiveSheet.UsedRange.Rows.Count, .Column).Address)
End With
End If
End Sub
I am new to this forum, so bear with me.
I have a CSV-file that I need to apply some VBA-modules to in order to get the information I need.
In short, I have 3 macros that together to the following:
Create a new row every 20th row
Take the number from the cell above (column A) and fill the blank space in the new row with this number.
Sum the numbers in column H from the 20 rows before the new row to get a total score. This is done subsequently for as long as new rows appear (every 20th row).
Is it possible to get these three macros in a single macro? This would make it easier to hand down to others that may need to use these macros.
Current code:
' Step 1
Sub Insert20_v2()
Dim rng As Range
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
End Sub
' Step 2
Sub FillBlanks()
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
' Step 3
Sub AutoSum()
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
End Sub
Thank you for any help.
Best,
Helge
You can create a single Sub calling all the other subs that you have created.
Example:
Sub DoAllTasks()
Insert20_v2
FillBlanks
AutoSum
End Sub
Then you just have to create a button and assign the DoAllTasks to it or run the macro directly.
HTH ;)
That Should'nt be that hard.
Public Sub main()
'deklaration
Dim rng As Range
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
'Loop trough all Rows
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
'Fill the Blank Rows in A
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
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