Excel VBA strip string into another cell - excel

I´m trying to create an Excelsheet that runs multiple VBA scripts after writing anything in A Column.
One part I would like some help with is that the character 2,3 and 4 written in A column (any row) should be written i D column same row.
I also would like to remove any information i D Column if I remove the text from A Column.
I have manage to create a script that calls modules after writing information i a cell in A Column
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
On Error GoTo Finalize 'to re-enable the events
Call Modul1.Module
Finalize:
Application.EnableEvents = True
End Sub
Any help would be much appriciated.
This is what I have for now.
It doesn´t work to clear value on all rows only some of them?!
Sub Lokation()
Dim n As Long, i As Long, j As Long
n = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
For i = 2 To n
If Cells(i, "A").Value = vbNullString Then
Cells(j, "D").Value = ("")
Else
Cells(j, "D").Value = Mid(Cells(j, "A").Value, 2, 3)
End If
j = j + 1
Next i
End Sub

You can wrap this whole piece up in just the Worksheet_Change event if you use the following:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim columnAcell As Range
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each columnAcell In Target.Cells
columnAcell.Offset(0, 3) = Mid(columnAcell, 2, 3)
Next
Application.EnableEvents = True
End Sub
Instead of specifically writing to column D, I've used a cell offset of 3 columns from Target. As this code only looks at column A currently, it will always offset to column D.
Things to watch out for though -
Altering cell(A1) which contains the header would result in cell(D1) being altered. You can prevent this by changing the Intersect range from A:A to something like A2:Axxxx
Deleting the entirety of column A would result in the loop running for a very long time, not to mention causing column D to move to column C. You may want to prevent users from being able to do this.

Related

Link two tables so a replacement in one is applied to the other

I have two tables in Excel that come from VBA data extraction from some other software.
I’d like for the common values in the NAME column on each table to be linked.
If, for instance, I replaced ABC02 in the second table with ABC03 then the first table’s ABC02 would be replaced with ABC03 as well.
Conversely a change in the first table would lead to a change in the second one.
I tried using the Handle value to mark identical values with the following code:
Sub Test1()
Dim i, y As Integer
For i = 10 To 11
y = 7
Do Until y = 5
y = y - 1
If Range("C" & y).Value = Range("C" & i).Value Then
Range("D" & y).Value = Range("B" & i).Value
End If
Loop
'' Action :
Next i
End Sub
Which gave this result:
How do I efficiently do it both ways (meaning getting the handles of similar values for the other table as well) to get that result:
and how to go from there (or even if I should do that at all).
This is a synchronisation issue and there is no quick and easy solution for that. What I would do is to use 2 event handlers of VBA: Worksheet_SelectionChange and Worksheet_Change. With the Worksheet_SelectionChange you can detect where the user has clicked and save the original value and address of the cell to some globally accessible variables. Then with the Worksheet_Change you can detect the user changes the value of the cell. Then you will have the original and the new value of cell. You need to manage multiple selection either, I give you a simple example in the following snippet.
Public origval As Variant, origaddr As Variant
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
origval = Target.Cells(1).Value
origaddr = Target.Cells(1).Address ' this is to handle multiple selection
Range(origaddr).Select ' reset multiple selection
End Sub
Public Sub Worksheet_Change(ByVal Target As Range)
' at this point
' - origval contains the original value
' - origaddr and Target.Address contains the cell address (should be the same)
' - Target.Value contains the new value of the cell
' - Target.Address contains the cell address
' - Target.Parent.Name contains the name of worksheet
' - Target.Parent.Parent.Name contains the name of workbook
' so you know everything you need and you can decide how to go on
End Sub
NB: the trick in SelectionChange is rather a "dirty" one. This is just a reminder to handle multiple selection, too.
Someone from another forum posted the following answer (so I'm posting it here in case anyone is looking for the same thing):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Variant
Application.EnableEvents = False
Set f2 = Sheets("Image")
If Not Intersect(Target, Columns(3)) Is Nothing Then
If Range(Target.Address).Value <> f2.Range(Target.Address).Value Then
TargetImage = f2.Range(Target.Address).Value
With f2
Set x = Columns(3).Find(TargetImage)
If Not x Is Nothing Then
Pos = x.Address
Do
If x.Row <> Target.Row Then
Cells(x.Row, "C") = Target.Value
'Modification of the Image sheet
f2.Cells(x.Row, "C") = Target.Value
f2.Range(Target.Address).Value = Target.Value
Else
Set x = .FindNext(x)
End If
Loop While Not x Is Nothing And x.Address <> Pos
End If
End With
End If
End If
Set f2 = Nothing
Application.EnableEvents = True
End Sub
This code assumes that:
There are 2 identical sheets and the second one is called "Image"
The user input is in the first sheet
The values we want to replace are both in the 3rd column
There are no duplicate values within the same table
If you want to execute another macro beforehand (like I do with my data extraction) you have to use that bit of code within that macro
On Error GoTo ErrHandler
Application.EnableEvents = False
'Your code here...
ErrHandler:
Application.EnableEvents = True
If somehow you modify that Worksheet_Change macro and get an error, you have to fix that error and enable events again with another macro like this one:
Sub ReenableEventsAfterError()
Application.EnableEvents = True
End Sub

Calculate only selected row

I have a large workbook and am trying to increase performance.
Is it possible/viable to store my formulas in some sort of list contained within the code rather than in the cells on the spreadsheet?
Variable SelectedRow = the currently selected row
For example:
ColumnBFormula = A(SelectedRow) + 1
ColumnCFormula = A(SelectedRow) + 2
If the user enters 4 in cell A3, then the macro writes formulas above ONLY in empty cells B3 and C3, then converts to values. The rest of the spreadsheet remains unchanged (should only have values everywhere).
Then the user enters a 6 in cell A4 and the spreadsheet writes the formulas to empty cells B4 and C4, calculates then converts to values.
Thanks
Try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lastrow As Long
'Refer to Sheet1
With ThisWorkbook.Worksheets("Sheet1")
'Check if Column A affected
If Not Intersect(Target, Range("A:A")) Is Nothing And IsNumeric(Target) Then
'Disable event to avoid event trigger
Application.EnableEvents = False
Target.Offset(0, 1).Value = Target + 1
Target.Offset(0, 2).Value = Target + 2
'Enable event
Application.EnableEvents = True
End If
End With
End Sub
Instructions:
Enable Events:
Given you know what you want the code to do, you could do this without entering formulas.
In the VBA editor, add this code into the "ThisWorkbook" object ...
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim objCell As Range
Application.EnableEvents = False
For Each objCell In Target.Cells
If objCell.Column = 1 Then
If objCell.Value = "" Then
objCell.Offset(0, 1) = ""
objCell.Offset(0, 2) = ""
Else
objCell.Offset(0, 1) = objCell.Value + 1
objCell.Offset(0, 2) = objCell.Value + 2
End If
End If
Next
Application.EnableEvents = True
End Sub
Hopefully that works for you.
FYI - You'll need to add the relevant error checking for values if not numeric etc, it will need to be improved.

Put timestamp when a checkbox is ticked or unticked

I have a worksheet with 3 rows and 7 columns (A1:G3).
A and B columns have 6 checkboxes (A1:B3). Boxes in columns A & B are linked to columns C & D respectively. Cells in columns E & F are just replicating columns C & D respectively (live E1 cell is =C1 and F3 cell is =D3).
I want to put a timestamp in cell G for each row when a checkbox is ticked or unticked by using Worksheet_Calculate event in VBA for that sheet.
My code works when used for just 1 row.
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
End Sub
I want to combine the code for 3 rows.
Here are 2 variations:
1st one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
Set cbX2 = Range("A2:F2")
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
ElseIf Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
ElseIf Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them with ElseIf like in the code above, a timestamp gets put in only G1, no matter if I tick B1 or C2.
2nd one:
Private Sub Worksheet_calculate()
Dim cbX1 As Range
Dim cbX2 As Range
Dim cbX3 As Range
Set cbX1 = Range("A1:F1")
If Not Intersect(cbX1, Range("A1:F1")) Is Nothing Then
Range("G1").Value = Now()
End If
Set cbX2 = Range("A2:F2")
If Not Intersect(cbX2, Range("A2:F2")) Is Nothing Then
Range("G2").Value = Now()
End If
Set cbX3 = Range("A3:F2")
If Not Intersect(cbX3, Range("A3:F3")) Is Nothing Then
Range("G3").Value = Now()
End If
End Sub
When I combine them by ending each one with End If and start a new If, timestamp gets put in all of the G1, G2 and G3 cells, even if I tick just one of the boxes.
You seem to be confusing Worksheet_Calculate with Worksheet_Change and using Intersect as if one of the arguments was Target (which Worksheet_Calculate does not have).
Intersect(cbX1, Range("A1:F1")) is always not nothing because you are comparing six apples to the same six apples. You might as well ask 'Is 1,2,3,4,5,6 the same as 1,2,3,4,5,6?'.
You need a method of recording the values of your range of formulas from one calculation cycle to the next. Some use a public variable declared outside the Worksheet_calculate sub procedure; personally I prefer a Static variant array declared within the Worksheet_calculate sub.
The problem with these is initial values but this can be accomplished since workbooks undergo a calculation cycle when opened. However, it is not going to register Now in column G the first time you run through a calculation cycle; you already have the workbook open when you paste in the code and it needs one calculation cycle to 'seed' the array containing the previous calculation cycle's values.
Option Explicit
Private Sub Worksheet_Calculate()
Static vals As Variant
If IsEmpty(vals) Then 'could also be IsArray(vals)
vals = Range(Cells(1, "A"), Cells(3, "F")).Value2
Else
Dim i As Long, j As Long
With Range(Cells(1, "A"), Cells(3, "F"))
For i = LBound(vals, 1) To UBound(vals, 1)
For j = LBound(vals, 2) To UBound(vals, 2)
If .Cells(i, j).Value2 <> vals(i, j) Then
Application.EnableEvents = False
.Cells(i, "G") = Now
Application.EnableEvents = True
vals(i, j) = .Cells(i, j).Value2
End If
Next j
Next i
End With
End If
End Sub

Rearrange Row data based on cells values automatically

Sheet1 Have 90 columns and 288 rows. Some cells of each row have value and some are blank (containing formula). I want to rearrange each row data in Sheet2 as value contain cells come to left and blank goes to right. I don’t want to remove the blank cells so, if a row doesn’t have any data will not got removed. Row order is very important in my case.
Sheet1 got updated each 5 minutes, if there is any possibility to update Sheet2 each 5 minute that will be really great.
Example:
Sheet1
Sheet1
Sheet2Sheet2
NB: My VBA or Macro knowledge is very basic. If I’m not asking too much, explanation to apply the solutions will be great.
Using office 365 latest version
If you are having a hard time finding a place to start, you could try this Worksheet_Change event macro for Sheet1.
Option Explicit
Private dALL As Double
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Sum(Target.Parent.UsedRange.Cells) <> dALL Then
dALL = Application.Sum(Target.Parent.UsedRange.Cells)
On Error GoTo bm_Safe_Exit
'suspend events so nothing on Sheet2 gets triggered
Application.EnableEvents = False
Dim a As Long, i As Long, j As Long, aVALs As Variant
aVALs = Target.Parent.UsedRange.Cells.Value2
For i = LBound(aVALs, 1) To UBound(aVALs, 1)
For j = LBound(aVALs, 2) To UBound(aVALs, 2) - 1
If Not CBool(Len(aVALs(i, j))) Then
For a = j + 1 To UBound(aVALs, 2)
If CBool(Len(aVALs(i, a))) Then
aVALs(i, j) = aVALs(i, a)
aVALs(i, a) = vbNullString
Exit For
End If
Next a
End If
Next j
Next i
With ThisWorkbook.Worksheets("Sheet2")
.UsedRange.Clear
.Cells(1, 1).Resize(UBound(aVALs, 1), UBound(aVALs, 2)) = aVALs
End With
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub

VBA Macro to delete unchecked rows using marlett check

I don't really have much of a background in VBA, but I'm trying to create a macro where, on the push of a button all rows that do not have a check mark in them in a certain range are deleted. I browsed some forums, and learned about a "marlett" check, where the character "a" in that font is displayed as a check mark. Here is the code I have to generate the "marlett check" automatically when clicking a cell in the A column in the appropriate range:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A10:A111")) Is Nothing Then
Target.Font.Name = "Marlett"
If Target = vbNullString Then
Target = "a"
Else
Target = vbNullString
End If
End If
End Sub
I then have another macro (assigned to a button) that actually deletes the rows without a check mark in the "A" column when the button is pressed:
Sub delete_rows()
Dim c As Range
On Error Resume Next
For Each c in Range("A10:A111")
If c.Value <> "a" Then
c.EntireRow.Delete
End If
Next c
End Sub
Everything works, but the only problem is that I have to press the button multiple times before all of the unchecked rows are deleted!! It seems like my loop is not working properly -- can anyone please help??
Thanks!
I think this may be due to how you're deleting the rows, you might be skipping a row after every delete.
You might want to change your for-each for a regular for loop. so you can control the index you'r working on. see this answer or the other answers to the question to see how to do it.
Heres a modified version that should suit your (possible) problem.
Sub Main()
Dim Row As Long
Dim Sheet As Worksheet
Row = 10
Set Sheet = Worksheets("Sheet1")
Application.ScreenUpdating = False
Do
If Sheet.Cells(Row, 1).Value = "a" Then
'Sheet.Rows(Row).Delete xlShiftUp
Row = Row + 1
Else
'Row = Row + 1
Sheet.Rows(Row).Delete xlShiftUp
End If
Loop While Row <= 111
Application.ScreenUpdating = True
End Sub
Update
Try the edit I've made to the if block, bit of a guess. Will look at it when I have excel.
It does go into an infinite loop regardless of the suggested change.
The problem was when it got near the end of your data it continually found empty rows (as theres no more data!) so it kept deleting them.
The code below should work though.
Sub Main()
Dim Row As Long: Row = 10
Dim Count As Long: Count = 0
Dim Sheet As Worksheet
Set Sheet = Worksheets("Sheet1")
Application.ScreenUpdating = False
Do
If Sheet.Cells(Row, 1).Value = "a" Then
Row = Row + 1
Else
Count = Count + 1
Sheet.Rows(Row).Delete xlShiftUp
End If
Loop While Row <= 111 And Row + Count <= 111
Application.ScreenUpdating = True
End Sub

Resources