I'm looking to search a sheet with shapes containing text that match the "A" column and then to change it to the corresponding "B" column. I wish to do so with multiple shapes. I have linked to a simplified version of the sheet
I will be working on:
Sub linkCell()
For i = 1 To 3
For j = 1 To 3
If ActiveSheet.Shapes(i).Value = ActiveSheet.Range("A" & j).Value Then
ActiveSheet.Shapes(i).Value = "=B" & j
End If
Next j
Next i
End Sub
This is faithful to your vision:
Sub linkCell()
Dim s As Shape, r As Range
For Each r In [a1:a3]
For Each s In ActiveSheet.Shapes
If r = s.TextFrame.Characters.Caption Then
s.OLEFormat.Object.Formula = "=" & r(, 2).Address
Exit For
End If
Next
Next
End Sub
Related
I am very new to VBA and have been stuck on this for a few days now.
I would like to compare H2 and H3. If equal then turn the cell green , If not equal then turn the cell red.
Once this is complete I would like to do the same for H4 and H5 , then H6 and H7...... all the way down to the last row of data.
Thank you in advance for your help .
How about something like this?
Sub ForLoopTest()
Dim loop_ctr As Integer
Dim Max As Integer
Max = ActiveSheet.UsedRange.Rows.Count
For loop_ctr = 1 To Max
If loop_ctr Mod 2 = 0 Then
row_below = loop_ctr + 1
If Cells(loop_ctr, "H") = Cells(row_below, "H") then
Cells(loop_ctr, "H").Interior.ColorIndex = 4
Cells(row_below, "H").Interior.ColorIndex = 4
Else
Cells(loop_ctr, "H").Interior.ColorIndex = 3
Cells(row_below, "H").Interior.ColorIndex = 3
End If
End If
Next loop_ctr
End Sub
I still feel like conditional formatting is they way to go here so that it's reactive to values changing in the worksheet, but if you are stuck on VBA as a solution here, something like this should do the trick:
Sub greenOrRed()
Dim lngRow As Long
For lngRow = 2 To Sheet1.Range("H2").End(xlDown).Row Step 2
If Sheet1.Range("H" & lngRow).Value = Sheet1.Range("H" & lngRow + 1).Value Then
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 4
Else 'didn't match
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 3
End If
Next lngRow
End Sub
You could also use a For Each loop to walk down the column which makes for some nice to read code. You just have to apply a test for Mod 2 on the row you are analyzing instead of using the very handy STEP 2 like in the For loop above:
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then
If rngCell.Value = rngCell.Offset(1).Value Then
rngCell.Resize(2).Interior.ColorIndex = 4
Else
rngCell.Resize(2).Interior.ColorIndex = 3
End If
End If
Next rngCell
End Sub
And if you really want to condense it you can apply some boolean math to the setting of the interior.ColorIndex, but this only works because red and green are 1 colorindex value away from each other. Also the next person that adopts your code will hate you and won't think your nearly as clever as you think you are.
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then rngCell.Resize(2).Interior.ColorIndex = 3 + Abs(rngCell.Value = rngCell.Offset(1).Value)
Next rngCell
End Sub
some other ways
another loop approach:
Sub CompareCells()
Dim i As Long
With Range("H2", Cells(Rows.Count,"H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
For i = 1 To .Count Step 2 ' loop through referenced range skipping every other row
With .Cells(i, 1) ' reference current cell
.Interior.Color = IIf(.Value2 = .Offset(1).Value2, vbGreen, vbRed) 'set current cell color with respect to below cell content
End With
Next
End With
End Sub
a no-loop approach:
Sub CompareCells()
With Range("H2", Cells(Rows.Count, "H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
With .Offset(, 1) ' reference referenced range 1 column to the right offset range. this is a "helpre" column
.FormulaR1C1 = "=IF(even(row())=row(),1,"""")" ' write 1's every two rows in referenced range
With .SpecialCells(xlCellTypeFormulas, xlNumbers) ' reference referenced range "numbered" rows
.Offset(, -1).Interior.Color = vbRed ' mark referenced range 1 column left offset in red
.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,"""")" ' signal referenced range cells with 1 if corresponding 1 column to the left offset cell content equals its below cell content
.SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1).Interior.Color = vbGreen ' turn reference referenced range "numbered" cells color to green
End With
.ClearContents ' clear referenced "helper" column
End With
End With
End Sub
I need your help in nexted VBA loop. I have some data in two columns and blank rows between rows. This macro loop through a column and find out if it contain certain character. If it' blank then I want it to move to next row. If it contain "Den", then select a specific worksheet ("D-Temp") else select ("M-Temp").
After selecting right Worksheet, it need to fill up text boxs with data from 2nd column as per Row no. The code I have created so far is
Sub Template()
Dim j As Long
Dim c As Range, t As Range
Dim ws As String
j = 5
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value = "" Then
Next ' `Not getting how to jump to next one`
ElseIf c.Value = "DEN" Then
ws = "D-Temp"
Else
ws = "M-Temp"
End If
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
Next
End With
Any help ??
Below is the sample Data I have :
Type Name 1 Name2
DEN Suyi Nick
'Blank row'
PX Mac Cruise
I want macro to Identify Type & select template worksheet (D or M) as per that and fill textboxes on that template with Name 1 & Name2 respectively.
may be you're after this:
Option Explicit
Sub Template()
Dim c As Range
With Sheets("Sample")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced sheet column C not empty cells form row 3 down to last not empty one
Worksheets(IIf(c.Value = "DEN", "D-Temp", "M-Temp")).Copy after:=Sheets(Sheets.Count) ' create copy of proper template: it'll be the currently "active" sheet
With ActiveSheet ' reference currently "active" sheet
.Shapes("Textbox 1").TextFrame.Characters.Text = c.Offset(, 7).Value ' fill referenced sheet "TextBox 1" shape text with current cell (i.e. 'c') offset 7 columns (i.e. column "P") value
.Shapes("Textbox 2").TextFrame.Characters.Text = c.Offset(, 6).Value ' fill referenced sheet "TextBox 2" shape text with current cell (i.e. 'c') offset 6 columns (i.e. column "O") value
End With
Next
End With
End Sub
If I'm not mis-understanding your current nesting...
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value <> "" Then
If c.Value = "DEN" Then
ws = "D-Temp"
Else
ws = "M-Temp"
End If
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
End if 'not blank
Next
End With
If I understand your question, correctly, you need to change your if/then logic slightly:
Sub Template()
Dim j As Long
Dim c As Range, t As Range
Dim ws As String
j = 5
With Sheets("Sample ")
For Each c In .Range("I3", .Cells(.Rows.Count, "I").End(xlUp))
If c.Value <> "" Then
If c.Value = "DEN" Then
ws = "D-Temp"
Exit For
Else
ws = "M-Temp"
Exit For
End If
End If
Next
For Each t In .Range("P3", .Cells(.Rows.Count, "P").End(xlUp))
If t.Value <> "" Then
j = j + 1
Sheets("M-Temp").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Shapes("Textbox 1").TextFrame.Characters.Text = t.Value
ActiveSheet.Shapes("textbox 2").TextFrame.Characters.Text = t.Offset(, -1).Value
End If
Next
End With
End Sub
You might want to add code to make sure that ws is set to something (not all columns were blank).
I am trying to Index/Match data only when a certain criteria is met.
I could do this with two arrays but I'm hoping there's an easy answer here.
My code is as follows:
Sub Nozeroleftbehind(lengthRow As Integer)
For i = 2 To lengthRow
If Cells(1, i) = 0 Then Cells(1, i) = "TBD"
Next i
For i = 2 To lengthRow
If Cells(1, i) = "#N/A" Then
Cells(2, i) = "=INDEX(Forecast!L:L,MATCH('AA - Inbound Orders Weekly Rep'!H113,Forecast!A:A,0))"
End if
Next i
End Sub
And then pass that sub back to the main routine.
What I am trying to get dynamic is that 'H113' cell. I can't seem to get an offset to work properly since it's already in a formula.
EDIT: Apologies, H113 moves down. Next cell would be H114.
Regards
Please try this code.
Sub NoZeroLeftBehind(lengthRow As Integer)
' 18 Oct 2017
Dim lengthRow As Long
Dim Tmp As Variant
Dim C As Long
lengthRow = 4
For C = 2 To lengthRow
' bear in mind that the Cell is a Range
' and you want to refer to its Value & Formula property
With Cells(1, C)
Tmp = .Value
' using the Val() function will interpret a blank cell as zero value
If Val(Tmp) = 0 Then
.Value = "TBD"
ElseIf IsError(Tmp) Then
.Formula = "=INDEX(Forecast!L:L,MATCH('AA - Inbound Orders Weekly Rep'!H" & _
(113 + C - 2) & ",Forecast!A:A,0))"
End If
End With
Next C
End Sub
Knowing that you want to go H113, H114:
Cells(2, i) = "=INDEX(Forecast!L:L,MATCH('AA - Inbound Orders Weekly Rep'!H" & CStr(111 + i) & ",Forecast!A:A,0))"
I am trying to set up my user form to do a loop or look up to reference my table which is on a sheet and is a large data base.
I want my user form to look up what I type and then auto fill in the other textboxes so that I can limit the number of duplicates and make it more stream lined.
My code is as shown below is embedded into Textbox1 and is set up to run the code after change. It is still not working and I have worked for many days and weeks trying to figure this out.
Option Explicit
Dim id As String, i As String, j As Integer, flag As Boolean
Sub GetDataA()
If Not IsNumeric(UserForm1.TextBox1.Value) Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 7
UserForm1.Controls("TextBox" & j).Value = Cells(i + 1, j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 5 To 10
UserForm1.Controls("TextBox" & j).Value = ""
Next j
End If
Else
End If
End Sub
you may want to adopt this refactoring of your code
Option Explicit
Sub GetDataA()
Dim j As Integer
Dim f As Range
With UserForm1 '<--| reference your userform
If Not IsNumeric(.TextBox1.Value) Then Exit Sub '<--| exit sub if its TextBox1 value is not a "numeric" one
Set f = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Find(what:=.TextBox1.Value, LookIn:=xlValues, lookat:=xlWhole) '<--| try and find its TextBox1 value along column "A" cells from row 1 down to last not empty one
If f Is Nothing Then '<--| if not found
For j = 5 To 10
.Controls("TextBox" & j).Value = ""
Next j
Else '<--| if found
For j = 2 To 7
.Controls("TextBox" & j).Value = f.Offset(, j - 1).Value
Next j
End If
End With
End Sub
note: if this sub is actually inside UserForm1 code pane than you can change With UserForm1 to With Me
I have non-microsoft files that have look along the lines of:
>gibberish that changes
AAARRGGGHHHH
Now, I have a code to make a new .xlsx file out of this to split using Trying to convert files while keeping the old name.
However, I would like the "A2" cell contents to split with each indivual letter being assigned a cell and then have the former contents deleted. I don't mind if this ends up in A3 till AZ.
Thus, the above example I would like to transform to make it look like:
>gibberish that changes
A A A R R G G G H H H H
To clarify "Gibberish that changes" is not a constant it changes per file I have what is denoted here. Same holds true for the second line.
Based on Split cell string into individual cells
I tried this code:
Dim sVar1 as string
Dim sVar2 as string
I = InStr(1, strX, "A" & "R" & "G" & "H")
sVar1 = mid(strX, 1, I)
sVar2 = mid(strx,i+1)
However, this yields no results. It does not cause the Macro to fail (as I get no error message and the rest of the macro works (changing a file into another format and altering the name), but it doesn't do anything. I would like to use the string as the files constantly change in contents and order in cell A2.
I also have no true delimiter as things like ARRGHHHH is written as one word, is that causing the issue?
my 0.02 with Character object
Sub main()
With Range("A2")
For i = 1 To Len(.Value)
.Offset(, i) = .Characters(i, 1).Text
Next i
End With
End Sub
This will parse A2 into its characters and place the characters next to A2, each in its own cell:
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 1 To L
.Offset(0, i).Value = Mid(v, i, 1)
Next i
End With
End Sub
EDIT#1:
This will handle both a range of input cells and the clearing of the original input data. Before:
The new macro:
Sub dural2()
Dim rng As Range, r As Range, v As Variant
Dim L As Long, i As Long
Set rng = Range("A2:A40")
For Each r In rng
v = r.Value
L = Len(v)
For i = 1 To L
r.Offset(0, i - 1).Value = Mid(v, i, 1)
Next i
Next r
End Sub
The result:
Would this be helpful at all?
Sub Test()
Dim i As Integer
Dim num As Integer
num = Len(Range("A1"))
For i = 1 To num
Debug.Print Mid(Range("A1"), i, 1)
Next
End Sub
Try this.
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 0 To L - 1
If i = 0 Then
.Offset(0, i).Value = Left(v, 1)
Else
.Offset(0, i).Value = Mid(v, i, 1)
End If
Next i
End With
End Sub
Input
output