Updated Question
I have a VBA script attached to sheet 1 that uses the B5:B50 cell values to populate the adjacent column with pre-defined text. If I want to use this script in another sheet, but still use the B5:B50 cell values of the previous sheet. How to I do that?
For Example:
In sheet 1, If I enter the value of 2 in the cell B5, it will populate D5 and E5 with the text value attached to CONST TXT. I want to do the same thing in sheet 2, but instead of the user entering the value again into B5 of sheet 2, it just gets the value of B5 from the previous sheet and then populate D5 and E5.
Sheet 2 B values will need to update as soon as the B values are updated in Sheet 1.
Private Sub Worksheet_Change(ByVal Target As Range)
Const NUM_COLS As Long = 5
Const TXT = "• Course Name:" & vbNewLine & _
"• No. Of Slides Affected:" & vbNewLine & _
"• No. of Activities Affected:"
Dim rng As Range, i As Long, v
If Target.CountLarge <> 1 Then Exit Sub
If Not Intersect(Target, Me.Range("B5:B50")) Is Nothing Then
Set rng = Target.Offset(0, 2).Resize(1, NUM_COLS) 'range to check
v = Target.Value
If IsNumeric(v) And v >= 1 And v <= NUM_COLS Then
For i = 1 To rng.Cells.Count
With rng.Cells(i)
If i <= v Then
'Populate if not already populated
If .Value = "" Then .Value = TXT
Else
'Clear any existing value
.Value = ""
End If
End With
Next i
Else
rng.Value = "" 'clear any existing content
End If
End If
End Sub
As I understand you, you want something like an equivalent of offset which returns a range on a different sheet. There are a couple of options.
You can use Range.AddressLocal, which returns the address of Range without any worksheet or workbook qualifiers, and then apply this to the other worksheet:
'returns a cell 1 to the right of rng, but on Sheet2
Worksheets("Sheet2").Range(rng.Offset(0, 1).AddressLocal)
Or you can get the Row and Column properties of your range and use them in Cells in the other worksheet:
'returns a cell 1 to the right of rng, but on Sheet2
Worksheets("Sheet2").Cells(rng.Row, rng.Column + 1)
To use it in your code, I think it's just a case of replacing
If .Value = "" Then .Value = TXT
with
If Worksheets("Sheet2").Range(.Offset(0, 1).AddressLocal).Value = "" Then Worksheets("Sheet2").Range(.Offset(0, 1).AddressLocal).Value = TXT
and replacing
.Value = ""
with
Worksheets("Sheet2").Range(.Offset(0, 1).AddressLocal).Value = ""
(or the same using the Cells construction).
The below will copy the Target.Value into the same cell in Sheet2
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
If Not Intersect(Target, Me.Range("B5:B50")) Is Nothing And Target.Count = 1 Then
With Target
ws2.Cells(.Row, .Column).Value = .Value
End With
End If
End Sub
Related
am trying to get "values" in cells based on another cells "text" with multiple ranges.
if I put "ok" in "A1" then I get the value "66" in "B1" automatically
likewise
I want to put values one by one in "A2", "A3", "A4"... and to get values in B2, B3 B4...
here I have a code for a single cell.
If Not Application.Intersect(Target, range("A1")) Is Nothing Then
If Val(Target.Value) = ok Then
range("B1") = "66"
End If
End If
End Sub
This solution allows you to process both single and batch data entry into adjacent and non-adjacent cells of the specified column, forming the target value in other cells specified by the offset
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, cl As Range
Set Rng = Application.Intersect(Target, Me.Columns("A"))
If Not Rng Is Nothing Then
For Each cl In Rng
If cl = "ok" Then cl.Offset(, 1) = "66"
Next
End If
End Sub
Result:
I assume that you want the results to populate in the adjacent B column based on what they select in column A.
you could adapt your code to say:
Dim xRow As Long
xRow = ActiveCell.Row
If Not Application.Intersect(Target, Range("A" & xRow)) Is Nothing Then
If Target.Value = "ok" Then
Range("B" & xRow) = "66"
End If
End If
I'm trying to vlookup multiple selection(comma seperated) in single cell and get the ouput in next sheet in single cell with single value (Either "Y" or "N") based on the input criteria (opt LCD vendor column in input table image) and functional usecase column (slection of multiple value ";" seperated) in input table image:
Output conditions:
I should get the output as "Y" only if both/all/multiple selected criteria (functional usecaeses) are "Y"
if one selection is "N" and the remaining are "Y", output should be "N"
Not sure it could be done in VBA / formula. could you please help on it.
As of now, Used this code for multi select functionality in functional usecase column & another 2 column
Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To allow multiple selections in a Drop Down List in Excel (without repetition)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
'MsgBox "called" + ActiveSheet.Name + "::" + Target.Address
If ActiveSheet.Name = "Input" Then
If (Target.Column = 19 Or Target.Column = 6 Or Target.Column = 13) Then
'If Target.Address = "O" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Sub test()
Set sh1 = Sheets("Sheet1")
Set rg = sh1.Range("B3", sh1.Range("B" & Rows.Count).End(xlUp))
Set sh2 = Sheets("Sheet2")
Set rgTbl = sh2.Range("A1", sh2.Range("F" & Rows.Count).End(xlUp))
For Each cell In rg
VL = "Y"
CL = rgTbl.Find(cell.Value, lookat:=xlWhole).Column
x = Split(cell.Offset(0, 1), ", ")
For i = LBound(x) To UBound(x)
VL = UCase(rgTbl.Find(x(i)).Offset(0, CL - 1))
If VL = "N" Then Exit For
Next
cell.Offset(0, 2).Value = VL
Next
End Sub
sh1 is the sheets where your "OPT LCD Vendor" reside.
So, change the sh1 according to your sheet name.
rg is the range of your "OPT LCD Vendor" header.
The code assumed that the data starts from cell B3 to the last rows which has value. rg values for example are : Outsystems, Any, Mendix, Unqork, etc.
sh2 is the sheet where your table has Y N.
So, change the sh2 according to your sheet name.
rgTbl is the range of the table in sh2.
The code assumed that the table starts from cell A1 to whatever last row in column F which has value. Change the range according to your need.
The process:
The code loop to each cell in rg,
get the value of the cell,
then find what column in rgTable this value exist, the CL variable.
The code split the value of the cell.offset(0,1) if the value has a comma separated.
For example, based on your image - the x variable will have two values : Life Origination and Accelerated Underwriting.
Then the code loop the value of x to get the VL is Y or N
Once it get the VL is N, it exit the loop, but it will continue if the value is not N. Finally the VL value (the result is Y or N) is put in column D of sh1 at the row of the looped cell, assuming that there is nothing in column D.
FYI, the value in column C of sh1 must always comma separated then one space. For example : Life Origination, Accelerated Underwriting ---> correct. Life Origination,Accelerated Underwriting ---> not correct.
This if I'm not mistaken to get what you mean.
I,ve tried to find a VBA solution for finding the previous cell (located on the same row) with different value than the selected cell has. So if the selected cell is for example [N6] (as in my picture) then my search range should be ("A6:N6") from which I need to find the last cell with a different cell value (which would be cell [L6] in my picture because it's the previous cell with a different value than cell [N6]. The search should start from the end (N6,M6,L6...) backwards until the first match is found (first different cell value). When the first match is found then select it. I have hundreds of columns, so my picture is just to show the principle. I execute my vba code with Private Sub Worksheet_SelectionChange(ByVal Target As Range) so when the user selects a cell with the mouse. I get the desired cell with {=ADDRESS(6;MATCH(2;1/(A6:O6<>"D")))} but I would need a VBA solution for my problem. My current VBA solution takes me to cell [I6] instead of [L6] and I can't figure out how to edit my code to find the correct cell ([L6] in my example picture).
Dim rngSel As String, rngStart As String
Dim rngActiveStart As Range
rngSel = ActiveCell.Address(0, 0)
rngStart = Cells(ActiveCell.Row, 1).Address(0, 0)
Set rngActiveStart = Range(rngStart & ":" & rngSel)
Dim c
For Each c In rngActiveStart.Cells
If c <> Target.Value And c.Offset(0, 1) = Target.Value Then
c.Select
MsgBox "Previous different cell: " & c.Address(0, 0)
Exit For
End If
Next
Using selection_Change
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Long, col As Long, x
Dim v As String
r = Target.Row
v = Target.Value
Application.EnableEvents = False
For x = Target.Column To 1 Step -1
With Me
If .Cells(r, x) <> v Then
.Cells(r, x).Select
Exit For
End If
End With
Next x
Application.EnableEvents = True
End Sub
You need a For i = max To min Step -1 loop to loop backwards/left:
Public Sub MoveLeftUntilChange()
Dim SelRange As Range 'remember the selected range 'N6
Set SelRange = Selection
Dim iCol As Long
For iCol = SelRange.Column To 1 Step -1 'move columns leftwards
With SelRange.Parent.Cells(SelRange.Row, iCol) 'this is the current row/column to test againts the remembered range N6
If .Value <> SelRange.Value Then 'if change found select and exit
.Select
Exit For
End If
End With
Next iCol
End Sub
I have a some data where I have some conditions. If each cell in column B contains words like "and", "or", "and/or", then create a copy of that row and insert it into next row following the copied row.
Currently my data looks like this:
This is my code:
Sub Macro2()
Dim rng As Range, cell As Range, rowRange As Range
Set rng = Range("B1", Range("B1").End(xlDown))
Dim values As Variant
Dim Result() As String
connectorArray = Array("and/or", "or", "and")
Dim findConnectorWord As String
'Worksheets("Sheet1").Activate
'Range("B1", Range("B1").End(xlDown)).Select
For Each cell In rng
findConnectorWord = FindString(cell.Value, connectorArray)
If findConnectorWord <> vbNullString Then
Result() = Split(cell, findConnectorWord)
Set rowRange = Range("A" & cell.Row, Range("B" & cell.Row).End(xlToRight))
rowRange.Copy
rowRange .Offset(1, 0).Insert Shift:=xlDown
'Logic to skip the next cell
End If
Next cell
End Sub
Function FindString(SearchString As String, arr As Variant) As String
For Each searchWord In arr
If InStr(SearchString, searchWord) > 0 Then
FindString = searchWord
Exit For
End If
Next
End Function
The problem that I am having is that once the row is copied and inserted into the next row, the next iteration reads the copied row("Homeowners or Dwelling Fire") and creates another copy. What I would like to do is to skip the cell once the row is copied, inside the if condition and look at Cell B3(Assuming that Umbrella (C) gets pushed down when the new cell is copied over). What's the best possible way to do this?
One of the possible options for implementing what #freeflow wrote about in his comment:
...
Set cell = Range("B1").End(xlDown) ' start from last cell
Do Until False
findConnectorWord = FindString(cell.Value, connectorArray)
If findConnectorWord <> vbNullString Then
...
Set rowRange = cell.EntireRow
rowRange.Copy
rowRange.Offset(1, 0).Insert Shift:=xlDown
End If
If cell.Row = 1 Then Exit Do ' First row? Enough
Set cell = cell.Offset(-1, 0) ' Shift up
Loop
...
And one more note - when defining values for connectorArray, add spaces to the terms: " and " instead of "and". Otherwise, you can duplicate the line with some Brandon or Alexandra
I need to find out the first cell and the last cell of a vertically merged cell..
Let's say I merge Cells B2 down to B50.
How can I get in VBA the start cell(=B2) and the end cell(=B50)?
Sub MergedAreaStartAndEnd()
Dim rng As Range
Dim rngStart As Range
Dim rngEnd As Range
Set rng = Range("B2")
If rng.MergeCells Then
Set rng = rng.MergeArea
Set rngStart = rng.Cells(1, 1)
Set rngEnd = rng.Cells(rng.Rows.Count, rng.Columns.Count)
MsgBox "First Cell " & rngStart.Address & vbNewLine & "Last Cell " & rngEnd.Address
Else
MsgBox "Not merged area"
End If
End Sub
Below macro goes through all sheets in a workbook and finds merged cells, unmerge them and put original value to all merged cells.
This is frequently needed for DB applications, so I wanted to share with you.
Sub BirlesenHucreleriAyirDegerleriGeriYaz()
Dim Hucre As Range
Dim Aralik
Dim icerik
Dim mySheet As Worksheet
For Each mySheet In Worksheets
mySheet.Activate
MsgBox mySheet.Name & “ yapılacak…”
For Each Hucre In mySheet.UsedRange
If Hucre.MergeCells Then
Hucre.Orientation = xlHorizontal
Aralik = Hucre.MergeArea.Address
icerik = Hucre
Hucre.MergeCells = False
Range(Aralik) = icerik
End If
Next
MsgBox mySheet.Name & " Bitti!!"
Next mySheet
End Sub
Suppose you merged B2 down to B50.
Then, start cell address will be:
MsgBox Range("B2").MergeArea.Cells(1, 1).Address
End cell address will be:
With Range("B2").MergeArea
MsgBox .Cells(.Rows.Count, .Columns.Count).Address
End With
You can put address of any cell of merged area in place of B2 in above code.
Well, assuming you know the address of one of the cells in the merged range, you could just select the offset from that range and get the row/column:
Sub GetMergedRows()
Range("A7").Select 'this assumes you know at least one cell in a merged range.
ActiveCell.Offset(-1, 0).Select
iStartRow = ActiveCell.Row + 1
Range("A7").Select
ActiveCell.Offset(1, 0).Select
iEndRow = ActiveCell.Row - 1
MsgBox iStartRow & ":" & iEndRow
End Sub
The code above will throw errors if the offset row cannot be selected (i.e. if the merged rows are A1 through whatever) so you will want to add error handling that tells the code if it can't offset up, the top rows must be 1 and if it can't go down, the bottom row must be 65,536. This code is also just one dimensional so you might want to add the x-axis as well.
If you want the cell references as strings, you can use something like this, where Location, StartCell, and EndCell are string variables.
Location = Selection.Address(False, False)
Colon = InStr(Location, ":")
If Colon <> 0 Then
StartCell = Left(Location, Colon - 1)
EndCell = Mid(Location, Colon + 1)
End If
If you want to set them as ranges, you could add this, where StartRange and EndRange are Range objects.
set StartRange = Range(StartCell)
set EndRange = Range (EndCell)
If you intend to loop through the merged cells, try this.
Sub LoopThroughMergedArea()
Dim rng As Range, c As Range
Set rng = [F5]
For Each c In rng.MergeArea
'Your code goes here
Debug.Print c.Address'<-Sample code
Next c
End Sub