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
Related
Excel 2019
Windows 10
Using VBA I Need to set the row height to 18 but for only rows that have data
I have tried variations on the following
Sub UsedRowsHeight1()
ActiveWorkbook.Worksheets("Titles Data").Range("A" & Rows.Count).End(xlUp).RowHeight = 18
End Sub
and
Sub UsedRowsHeight2()
Rows().AutoFit
Rows.End(xlUp).RowHeight = 18
End Sub
None do what I am looking for.
use this:
Sub UsedRowsHeight1()
lr = Sheets("Titles Data").UsedRange.Rows(Sheets("Titles Data").UsedRange.Rows.Count).Row
Sheets("Titles Data").Range("1:" & lr).RowHeight = 18
End Sub
this uses special cells to select rows that have data (so if you have empty rows between filled rows they will not be affected)
Sub ChangeRowHeight()
Dim rngConst As Range
Set rngConst = Cells.SpecialCells(xlCellTypeConstants, 23)
Dim rngForm As Range
Set rngForm = Cells.SpecialCells(xlCellTypeFormulas, 23)
Union(rngConst, rngForm).RowHeight = 18
End Sub
Please, use the next way:
If you need/want setting the row height for all used range, even if there are empty rows in between, please, use the next code:
Sub RowHeightForRowsForUsedRange()
Dim sh As Worksheet, lastR As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
sh.Range("A1:A" & lastR).RowHeight = 18
End Sub
To hide only rows of the used range having at least a cell with data on the row, please use the next version. In order to be fast, it uses a Union range to collect first cell of the rows having data and increase their height at once, at the code end:
Sub RowHeightForNotEmptyRowsInUsedRange()
Dim sh As Worksheet, lastR As Long, rngUR As Range, rngH As Range, i As Long
Set sh = ActiveSheet
Set rngUR = sh.UsedRange
For i = 1 To rngUR.rows.count
If WorksheetFunction.CountA(rngUR.rows(i)) > 0 Then
addToRange rngH, rngUR.cells(i, 1)
End If
Next i
If Not rngH Is Nothing Then rngH.EntireRow.RowHeight = 18
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
I have the following problem. I need to log changes in a spreadsheet. My range goes from A1:M300000.
So far I have managed to log the address of the changed cell, the user, the old value, and the new value.
Now I would like to insert the following functions and need help. It's the first time I come into contact with VBA:
I also want my log file to show the value of a cell in another column. So I know which object it is. Example change cell B26 and now also A26 should be displayed in the log file.
Furthermore, I also want to log when new cells are inserted or existing records are deleted.
Here is my VBA code:
Option Explicit
Dim mvntWert As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim lngLast As Long
Set wks = Worksheets("Protokoll")
lngLast = wks.Range("A65536").End(xlUp).Row + 1
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
With wks
.Range("A" & lngLast).Value = Target.Address(0, 0)
.Range("B" & lngLast).Value = mvntWert
.Range("C" & lngLast).Value = Target.Value
.Range("D" & lngLast).Value = VBA.Environ("Username")
.Range("E" & lngLast).Value = Now
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
mvntWert = Target.Value
End Sub
I hope someone can help me. Thank you very much in advance.
greeting
ironman
Please, try the next code, I prepared yesterday for somebody else asking for a similar issue. It needs only one event and should do what you require here:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
Dim sh As Worksheet: Set sh = Worksheets("Protokoll")
Dim UN As String: UN = Application.userName
'sh.Unprotect "" 'it should be good to protect the sheet
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
If Target.cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'avoiding to trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'define the RangeValue
putDataBack TgValue, ActiveSheet 'put back the changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
sh.cells(rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
End If
Next r
'sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.cells.count - 1)
For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.cells.count
arr(count) = Array(a.cells(i).value, a.cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function
I have the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count = 1 Then
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Dim cb As Object
Dim combineRange As Range
Dim boolStr As String
Dim floatStr As String
Dim booleanRange As Range
Dim floatRange As Range
Dim bRow As Integer
bRow = Worksheets("DEF_BOOLEAN").Cells(Rows.Count, 1).End(xlUp).Row
Dim fRow As Integer
fRow = Worksheets("DEF_FLOAT").Cells(Rows.Count, 1).End(xlUp).Row
boolStr = "A2:A" & bRow
floatStr = "A2:A" & fRow
Set booleanRange = Worksheets("DEF_BOOLEAN").Range(boolStr)
Set floatRange = Worksheets("DEF_FLOAT").Range(floatStr)
Set cb = Worksheets("FT_CASE_xx").OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, Left:=Target.Left, Top:=Target.Top, Width:=Target.Width, Height:=Target.Height).Object
For Each cell In booleanRange
cb.AddItem cell.value
Next cell
For Each cell In floatRange
cb.AddItem cell.value
Next cell
End If
End If
End Sub
which adds an ActiveX combobox each time I press on a Cell in the 'A' column.
That's work fine. The problem is that I would like the cell below (the one 'covered' by the combobox) get the value selected in the combobox.
That's why I thought to use the linkedCell property. unfortunately the following lines don't work:
cb.LinkedCell = Target
or
cb.LinkedCell = Target.address
How should it be set to achieve the result?
A slight change worked for me: change Dim cb As Object to Dim cb as ComboBox.
Then use cb.LinkedCell = Target.Address.
I am iterating through a column and wanting to catch the cells that meet the string of text that I am searching for. My problem occurs when I try and set the address of the cell that has met the criteria of the search into a Range object. Line:
Set testRng = i.Range.Adress
Gives me error " Wrong number of arguments or invalid property assignment" and I'm not sure what the issue is here?
This is the entire code I am working with:
Sub Tester()
Dim rng As Range
Dim testRng As Range
Dim i As Variant
Dim cmpr As String
Dim usrInputA As String
usrInputA = InputBox("Col 1 Criteria: ")
Set rng = Range("A2:A10")
For Each i In rng
cmpr = i.Value
If InStr(cmpr, usrInputA) Then
If testRng Is Nothing Then
Set testRng = i.Range.Address
Else
Set testRng = testRng & "," & i.Range.Address
End If
Else
MsgBox "No hit"
End If
Next
End Sub
You should declare i as a Range (not Variant)
Use Union to group together a collection of cells instead of trying to manually build the string yourself
Switch the order of your range set. You only need Set rngTest = i once so I would put this at the bottom so you don't have to keep spamming it.
Option Explicit
Sub Tester()
Dim testRng As Range, i As Range
Dim usrInputA As String
Dim LR as Long
usrInputA = InputBox("Col 1 Criteria: ")
LR = Range("A" & Rows.Count).End(xlUp).Row
For Each i In Range("A2:A" & LR)
If InStr(i, usrInputA) Then
If Not testRng Is Nothing Then
Set testRng = Union(testRng, i)
Else
Set testRng = i
End If
End If
Next i
If Not testRng is Nothing Then
'Do what with testRng?
End If
End Sub
I get this error when I am trying to open a UserForm. What I want is to add to a combobox all the different objects (not repeated) that are present in a column.
I have been looking some solutions around there and all I can say until now is Yes, I have a combobox called "offer1"
When it gives me the error, it highlight the .FindString() method inside the loop
Private Sub UserForm_Initialize()
Dim rCell As Range
Dim i As String
Dim ws As Worksheet
Dim text As String
text = rCell.text
ws = Offers
offer1.Clear
With offer1
For Each rCell In Sheets("Offers").Range("A2", Sheets("Offers").Cells(Rows.Count, "A").End(xlUp))
If TEST.offer1.FindString(text) = -1 Then
.AddItem CStr(text)
End If
Next rCell
End With
End Sub
(If you see some silly mistakes with the names of variables as "Ofertas" or something like that is probably that I translated some variable names to english, and I jumped over a few)
Thanks a lot
Replace your code with this:
Option Explicit
Private Sub UserForm_Initialize()
Dim rCell As Range
Dim ws As Worksheet
Dim LastRow As Long
Dim strFirstCell As String
Set ws = Sheets("Offers")
With Me.offer1
.Clear
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
strFirstCell = ws.Cells(2, "A").Address
For Each rCell In ws.Range(strFirstCell, ws.Cells(Rows.Count, "A").End(xlUp))
If Evaluate("=SUMPRODUCT((" & strFirstCell & ":" & rCell.Address(0, 0) & "=" & rCell.Address & ")+0)") = 1 And rCell.Value <> "" Then
.AddItem rCell.Value
End If
Next rCell
End With
End Sub
This will fill your combobox with all the unique items in column A, starting at row 2, while also skipping any blanks.