I want to make the average of the entries starting at B4. Tell me what should be changed in my code. Im new to vba.
Range("F13").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=AVERAGE(Range(Range("B4").End(xlDown)))"
Edit:
And how does it work in this case?
Range("F17").Select
Application.CutCopyMode = False
Range("F17").Formula = "=IF(COUNT(R[-13]C[-2]:R[-10]C[-2])=0,10^99,COUNT(" & Range(Range("D4"), Range("D4").End(xlDown)).Address & ")"
If your goal is to have the actual formula in the cell (so it will automatically update if the values on the worksheet change) then you could do it like:
Sub test()
Dim rgStart As Range, rgStop As Range, rg As Range
Set rgStart = Range("B4")
Set rgStop = rgStart.End(xlDown)
Set rg = Range(rgStart, rgStop)
Range("F13").Formula = "=AVERAGE(" & rg.Address & ")"
End Sub
...that is the tidier way to do it (more code but easier to understand).
This is the same code but more "compact":
Sub test()
Range("F13").Formula = "=AVERAGE(" & Range(Range("B4"), Range("B4").End(xlDown)).Address & ")"
End Sub
If you don't actually want the formula in the cell (so it's a static value) you can still call the worksheet AVERAGE function with Application.WorksheetFunction, like:
Sub test()
Dim rgStart As Range, rgStop As Range, rg As Range
Set rgStart = Range("B4")
Set rgStop = rgStart.End(xlDown)
Set rg = Range(rgStart, rgStop)
Range("F13") = Application.WorksheetFunction.Average(rg)
End Sub
...and again, "compacted":
Sub test()
Range("F13") = Application.WorksheetFunction.Average(Range(Range("B4"), Range("B4").End(xlDown)))
End Sub
Related
I have a large data set with a number of different columns to update. I am trying to create a way to timestamp a date/time as to when the last time a column was updated. I need to do this for 4 separate instances.
The issue i am having is that it seems to work fine for the first instance of the VBA but then wont execute on another column regardless. Please see my full code sample below:
Sub Worksheet_Change(ByVal Target As Range)
Dim myTableRange1 As Range
Dim myDateTimeRange1 As Range
Dim myUpdatedrange1 As Range
Set myTableRange1 = Range("S:S")
If Intersect(Target, myTableRange1) Is Nothing Then Exit Sub
Set myDateTimeRange1 = Range("A" & Target.Row)
Set myUpdatedrange1 = Range("X" & Target.Row)
If myDateTimeRange1.Value = "" Then
myDateTimeRange1.Value = Now
End If
myUpdatedrange1.Value = Now
End Sub
Sub Worksheet_Change2(ByVal Target As Range)
Dim myTableRange2 As Range
Dim myDateTimeRange2 As Range
Dim myUpdatedrange2 As Range
Set myTableRange2 = Range("T:T")
If Intersect(Target, myTableRange2) Is Nothing Then Exit Sub
Set myDateTimeRange2 = Range("zz" & Target.Row)
Set myUpdatedrange2 = Range("Y" & Target.Row)
If myDateTimeRange2.Value = "" Then
myDateTimeRange2.Value = Now
End If
myUpdatedrange2.Value = Now
End Sub
****UPDATE****
I have also tried to merge this code together like below:
Sub Worksheet_Change(ByVal Target As Range)
Dim myTableRange1 As Range
Dim myDateTimeRange1 As Range
Dim myUpdatedrange1 As Range
Dim myTableRange2 As Range
Dim myDateTimeRange2 As Range
Dim myUpdatedrange2 As Range
Set myTableRange1 = Range("S:S")
Set myTableRange2 = Range("T:T")
If Intersect(Target, myTableRange1) Is Nothing Then Exit Sub
If Intersect(Target, myTableRange2) Is Nothing Then Exit Sub
Set myDateTimeRange1 = Range("A" & Target.Row)
Set myUpdatedrange1 = Range("X" & Target.Row)
Set myDateTimeRange2 = Range("zz" & Target.Row)
Set myUpdatedrange2 = Range("Y" & Target.Row)
If myDateTimeRange1.Value = "" Then
myDateTimeRange1.Value = Now
If myDateTimeRange2.Value = "" Then
myDateTimeRange2.Value = Now
End If
myUpdatedrange1.Value = Now
End If
myUpdatedrange2.Value = Now
End Sub
And this resulted in neither working.
I am new to VBA so Any help would be appreciated. Thank you
You need something like this (in outline form) so as not to discount changes to a single column.
If you changed T only, your updated code would exit before getting to the relevant bit of code.
If you changed S and T, it would only do the S bit.
Sub Worksheet_Change(ByVal Target As Range)
Dim myTableRange1 As Range
Dim myDateTimeRange1 As Range
Dim myUpdatedrange1 As Range
Dim myTableRange2 As Range
Dim myDateTimeRange2 As Range
Dim myUpdatedrange2 As Range
Set myTableRange1 = Range("S:S")
Set myTableRange2 = Range("T:T")
If Not Intersect(Target, myTableRange1) Is Nothing Then
'your column S code
ElseIf Not Intersect(Target, myTableRange2) Is Nothing Then
'your column T code
End If
End Sub
I have two buttons, "multiply by 0" and "show original value".
For the "multiply by 0" button, I have the below code, which works fine. What I need help with is the code for the second button, which would make the range that is multiplied by 0 back to its original number).
Public Sub MultiplyByZero()
Dim rngData As Range
Set rngData = ThisWorkbook.Worksheets("Input Sheet LC").Range("I76:O103")
rngData = Evaluate(rngData.Address & "*0")
End Sub
Thanks for your help!
The below code may helps you.
Declare a global variable named arr so you can call it from anywhere - Dim arr As Variant
Before you multiple by zero we store the values in that array - arr = .Range("A1:A5")
At any time we can bring the values back - .Range("B1:B5").Value = arr
Option Explicit
Dim arr As Variant
Public Sub MultiplyByZero()
Dim rngData As Range
Dim cell As Range
With ThisWorkbook.Worksheets("Sheet1")
arr = ""
Set rngData = .Range("A1:A5")
arr = .Range("A1:A5")
rngData = Evaluate(rngData.Address & "*0")
End With
End Sub
Public Sub RestoreValues()
With ThisWorkbook.Worksheets("Sheet1")
If Not IsEmpty(arr)=True Then
.Range("A1:A5").Value = arr
Else
MsgBox "Array is empty."
End If
End With
End Sub
Using a formula instead of a constant:
Public Sub MultiplyByZero()
Dim rngData As Range, rngWork AS Range
Set rngData = ThisWorkbook.Worksheets("Input Sheet LC").Range("I76:O103")
For Each rngWork In rngData.Cells
With rngWork
If .HasFormula Then
If Right(.Formula,2) <> "*0" Then .Formula = .Formula & "*0"
Else
.Formula = "=" & .Value & "*0"
End If
End With
Next rngWork
End Sub
Public Sub DivideByZero()
Dim rngData As Range, rngWork AS Range
Set rngData = ThisWorkbook.Worksheets("Input Sheet LC").Range("I76:O103")
For Each rngWork In rngData.Cells
With rngWork
If .HasFormula Then
If Right(.Formula,2) = "*0" Then .Formula = Mid(.Formula, 1, Len(.Formula)-2)
End If
End With
Next rngWork
End Sub
This will change 10 into =10*0 and then back into =10
I am stuck with a problem i cannot get my head around currently.
I have a checklist that has to update automatically when adding lines to my excel worksheet so that the checklist is applied to all rows.
I tried to use a "for loop" to modify the formula but excel returns Error 1004, when starting the string with "=".
No error but no functionality as well:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "Wenn(Oder(AB" & firstRow & "=""x"""
Returns error 1004:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").FormulaLocal = "=Wenn(Oder(AB" & firstRow & "=""x"""
My first solution
Loop FormulaR1C1, or Formula and use nothing but english Function names eg. sum() instead of Summe() and follow english syntax , instead of ;.
Problem
When testing the syntax without a loop and actual indices it works like a charm. As soon as I try to loop it, Excel does not recognize R[i]C as cell anymore but just returns plain text.
no issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[1]C = ""x"""
issues:
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Formula = "IF(OR( R[i]C = ""x"""
Splitting it like this did not solve my problem either
..R[" & i & "]C =..
Any tips?
// For i= ... to .. next i
// Excel 2007
Try this:
With ActiveWorkbook.Sheets("Kalkulation Änderungen")
'find last row of column AB
LastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row
'apply the formula from AB9 to its last non-blank row
.Range("AB9:AB" & LastRow).Formula = "IF(OR( R[1]C = ""x"""
End With
#UGP: that is what i thought the code might look like after implementing your tips with intersect etc.
What do you think of it, I guess you might not like the loops too much?
Typical beginner approach to loop everything?
I would have to do this for every column accordingly?
If so it would be wise to create a sub () for every column with an exit condition so that i save computing time?
Unless it is possible to hand over the columnadress to the sub_worksheet_change()?
Private Sub Worksheet_Change(ByVal Target As Range, selected_column)
_
_
_
_
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim check As Boolean
frstRow = 1
lastRow = 1
i = 1
'Rowcount
Do Until firstRow <> 1 And lastRow <> 1
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("D" & i) = "Länge" Then
firstRow = i + 2
i = i + 1
End If
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("G" & i) = "Gesamt-h" Then
lastRow = i - 2
End If
i = i + 1
Loop
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & firstRow, "AI" & lastRow)
check = False
i = firstRow
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Do While i <= lastRow And check = False
If ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB" & i).Value = "x" Then
check = True
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = "x"
ElseIf i = lastRow And check = False Then
ActiveWorkbook.Sheets("Kalkulation Änderungen").Range("AB9").Value = " "
End If
i = i + 1
Loop
End If
End Sub
Here's the code. It has to be in the corresponding worksheet in the VBA-Editor.
It activates when a cell in Range(A10:A20) has been changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A10:A20")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Count = 1 Then
If Target.Value = "x" Then
'Your Code
'i.e
MsgBox (Target.Address & "has been changed")
End If
Else
MsgBox ("Please No Copy Pasterino")
End If
End If
End Sub
EDIT:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim i As Integer
Dim fRow As Long, lRow As Long
Dim check As Boolean
Dim sht As Worksheet
Dim Cell As Range
Set sht = Worksheets("Tabelle1")
'Rowcount
fRow = 2
lRow = sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
' check column AB fo "x" and modify header
Set KeyCells = Range("AB" & fRow & ":AI" & lRow)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
For Each Cell In Range(Cells(fRow, Target.Column), Cells(lRow, Target.Column))
If Cell.Value = "x" Then
sht.Cells(9, Target.Column).Value = "x"
Exit For
Else
sht.Cells(9, Target.Column).Value = ""
End If
Next
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 am placing a button on a sheet to allow to uppercase all items in two columns in a table.
Here is the code I have found elsewhere and adapted to try to make work:
Private Sub CommandButton1_Click()
With Range("B10", Cells(Rows.Count, "B").End(xlUp))
.Value = Evaluate("INDEX(UPPER(" & .Address(External:=True) & "),)")
End With
With Range("C10", Cells(Rows.Count, "C").End(xlUp))
.Value = Evaluate("INDEX(UPPER(" & .Address(External:=True) & "),)")
End With
End Sub
I want the Range to reference Table2, columns 1 & 2 instead of B & C.
Suggestions?
For access to all sorts of table ranges and references, you need to use a ListObject. Here's an example:
Option Explicit
Sub test()
Dim ws As Worksheet
Dim t2 As ListObject
Set ws = ActiveSheet
Set t2 = ws.ListObjects("Table2")
Debug.Print t2.ListColumns(1).Name
Dim refRange As Range
Set refRange = Union(t2.ListColumns(1).Range, t2.ListColumns(2).Range)
Debug.Print refRange.Address
End Sub