There is a small error in my For loop as it will not select the part that I want to color. I used a variable hash to put all the names of the document there and then tried the Catia function to color, but still got nothing!
Below is a part fo the code.
Problem zone is the Select Case. It wont actually select and color the part if found.
UPDATE: now i know exactly where the problem is, it is inside case during selection of the part and coloring it. somehow it wont even select the part.
For n = 1 To DokAnzahl
Set Dokument = DokumentArray(n)
ReDim DokumentArrayNew(DokAnzahl)
DokumentArrayNew(n) = CStr(Dokument.Name)
For j = 1 To UBound(arrNamen)
If arrNamenNew(j) = Left(DokumentArrayNew(n), Len(arrNamenNew(1))) Then
'MsgBox "They are equal!"
hash = DokumentArrayNew(n)
ColorCode(j) = arrFarben(j)
'MsgBox ColorCode(j) checked
m = j+1
Select Case ColorCode(j)
Case "NEU" 'rot
Set sel = catia.activedocument.selection
sel.search "Name =hash,all"
sel.visproperties.setRealColor 240, 1, 1, 1
Case "entfällt" 'Gelb
Set sel = catia.activedocument.selection
sel.search "Name =hash,all"
sel.visproperties.setRealColor 240, 240, 16, 1
Case "COP" 'Grün
Set sel = catia.activedocument.selection
sel.search "Name =hash,all"
sel.visproperties.setRealColor 30, 240, 60, 1
Case Else
MsgBox "no color info"
End Select
End If
Next
Next
Your Selection.Search is searching for the word "Hash" and not what is inside the variable hash
Change your Select Case statements to this:
Set sel = catia.activedocument.selection
sel.search "Name =*" & hash & "*,all"
Related
I'm trying to use a Vlookup function in order to find a copy of a State code on another worksheet. But the range is not matching up with the string. The range is literally just the 50 states and I'm trying to make it match.
I tried checking out to make sure that the state abbreviation was a string. I've also tried converting the range to a string, but that also caused an error. It's strange because if I just match the specific states together, it says that they equal.
Sub State_Assignment()
Application.ScreenUpdating = False
'On Error Resume Next
' State_Assignment Macro
Dim Counter As Integer
Counter = 1
Dim Other As Integer
Other = 0
Dim State As String
State = " "
'
'First, we will check for specialty brokers.
'Check if Specialty Broker requires a state to assign. In this case, we are making sure to include N and n as options, due to future proofing.
If Worksheets("SBSS_Assignment_Tool").Range("G3").Value = "None" Then
ElseIf CStr(Application.VLookup(G3, Worksheets("Special_Cases").Range("A3:A100"), 2)) = "N" Or CStr(Application.VLookup(G3, Worksheets("Special_Cases").Range("A3:A100"), 2)) = "n" Then
E5.Value = WorksheetFunction.VLookup(G3, Worksheets("Special_Cases").Range("A3:A100"), 3)
'If State is needed for Specialty Broker, make sure operator knows. In this case, we are making sure to include Y and y as options, due to future proofing.
ElseIf "Y" = CStr(Application.VLookup(G3, Worksheets("Special_Cases").Range("A3:A100"), 2)) Or "y" = CStr(Application.VLookup(G3, Worksheets("Special_Cases").Range("A3:A100"), 2)) Then
MsgBox ("State is reqired to assign SBSS for this broker.")
'This only leaves the case of Yes and the state is specified.
Else
' Select the cell of the Broker we are looking at.
Worksheets("Special_Cases").Activate
Range("A3:A100").Find(CStr(Application.VLookup(G3, Worksheets("Special_Cases").Range("A3:A100"), 1))).Select
' Now check to make sure the State isn't the cell in the same row as it.
If ActiveCell.Offset(0, 2) = Worksheets("SBSS_Assignment_Tool").Range(G20).Value Then
Worksheets("SBSS_Assignment_Tool").Range(J7).Value = ActiveCell.Offset(0, 3)
'See if there are more states to check, by seeing if there is a empty cell below. We use the Counter varible as future-proofing, so specialty brokers can have as many states as they need.
'The "Other" state specification can also be a problem, so if we see it, we will remeber it's cell and use it if none of the other states match up.
ElseIf ActiveCell.Offset(Counter, 0) = " " Then
If ActiveCell.Offset(Counter, 2) = Worksheets("SBSS_Assignment_Tool").Range(G20).Value Then
Worksheets("SBSS_Assignment_Tool").Range(J7).Value = ActiveCell.Offset(Counter, 3)
ElseIf ActiveCell.Offset(Counter, 2) = "Other" Then
Other = Counter
End If
Counter = Counter + 1
Else
'If we check all the states and none match, we use the "Other" cell.
Worksheets("SBSS_Assignment_Tool").Range(J7).Value = ActiveCell.Offset(Other, 3)
End If
End If
' Looks for State From Drop-Down List and Gather Rules From Cell To The Right of It
Worksheets("SBSS_Assignment_Tool").Range("J20") = Application.VLookup(Worksheets("SBSS_Assignment_Tool").Range("G20").Value, Worksheets("State_Assignments").Range("A2:A100"), 2)
'Check for Special Broker Rules, first ruling out the No's
MsgBox (CStr(Worksheets("SBSS_Assignment_Tool").Range("G20").Value) + " ")
State = Worksheets("SBSS_Assignment_Tool").Range("G20").Value
MsgBox (CStr(Worksheets("State_Assignments").Range("A16").Value) + " ") '
MsgBox (Worksheets("SBSS_Assignment_Tool").Range("G20").Value = Worksheets("State_Assignments").Range("A16").Value)
Dim X As Range
Set X = Worksheets("State_Assignments").Range("A1:A100")
MsgBox (Application.VLookup(State, Worksheets("State_Assignments").Range("A2:A51"), 3))
If Application.VLookup(Worksheets("SBSS_Assignment_Tool").Range("G20").Value, Worksheets("State_Assignments").Range("A1:A100"), 3) = "N" Then
Else
'Selec the cell of the SBSS
Worksheets("Special_Cases").Range("A1:AA1").Find(Application.VLookup(G20, Worksheets("State_Assignments").Range("A1:A100"), 3)).Select
J28.Value = ActiveCell.Offset(1, 0)
End If
The message boxes work, but once it gets the Vlookups is when it starts to flounder.
I have a sheet in which our wholesale team are to enter L09 Part Codes and quickly see how much we have in stock of that item. The problem is that new starters may struggle to learn these part numbers as they don't follow a simple rule. What I did was create an easier code to remember which is simply: "Cable Type" & "Core Size" & "Cut Length", they also have the option to add "Colour" and "Brand" separated by spaces.
Their entered string may look like 6242y 2.5 100, or maybe 6242y 2.5 100 Grey, etc. and so where to look in my mapped table for what they've written depends on how many terms they put in. As you can see from the attached picture I need to select the correct column to look in for their code, and then offset back a few columns to suggest the correct L09 Part Number.
I hope the context makes a bit of sense and helps with the below code. The idea was for a new starter to enter something simple and it be replaced before their very eyes...
If anyone could help me to correct the following it would be greatly appreciated:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim P, Products, S, Search As Range
Dim Column As String
Dim Counter As Integer
Dim Spaces As Long
'On Error Resume Next
Counter = 0
'For top table only
If Target.Column = 1 And Target.Row < 100 Then
'Count spaces
Spaces = UBound(Split(Target, " "), 1)
Select Case Spaces
Case Is = 2
Column = "M"
Case Is = 3
Column = "O"
Case Is = 4
Column = "Q"
End Select
'When string has spaces
If Spaces <> 0 Then
'Set simple code range
Set Search = Sheets("Cherries").Range(Column & 1 & ":" & Column & 10000)
For Each S In Search
If S = Target Then
Target = S.Offset(0, 3 - 2 * Spaces)
End If
Next S
End If
Set Products = Sheets("Order Entry").Range("A3:A99")
For Each P In Products
If P.Value <> "" Then
Counter = Counter + 1
End If
Next P
Sheets("Order Entry").Rows("3:" & Counter + 11).Hidden = False
Sheets("Order Entry").Rows(Counter + 11 & ":99").Hidden = True
End If
End Sub
Unfortunately I'm not sure which line is erroring as no error message is given.
Thank you for your time.
I am using a Word table as a placeholder for images, where table cells contain only pictures and no text.
When inserting a picture into a Word table, I have no problems when inserting an Inline Shape. The picture appears into the expected cell. However, with the "equivalent" code which inserts the picture as a Shape, the shape does not always appear in the expected cell. So far, I have seen this problem in Word 2013, 32 bit version.
Sub test()
Dim s As Shape
Dim x As String
Dim f As String
Dim r As Long
Dim c As Long
Dim h As Single
Dim w As Single
Dim rng As Word.Range
Dim ins As Word.InlineShape
f = "file name of a picture, .bmp .jpg etc."
Word.Application.ScreenUpdating = False
If Selection.Information(wdWithInTable) Then
' insert a picture in a table cell
r = Selection.Information(wdStartOfRangeRowNumber)
c = Selection.Information(wdStartOfRangeColumnNumber)
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With
' Works reliably
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
s.height = h
s.width = w
' Not at all reliable
' Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
Else
' insert a picture at the cursor
h = 100
w = 100
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h)
End If
Word.Application.ScreenUpdating = True
s.WrapFormat.Type = wdWrapInline
s.Title = "Title"
s.AlternativeText = "Some metadata"
End Sub
The idea is to select either a cell in a table in a document or somewhere on the page outside of the table. The outside of the table case works as expected where the picture appears at the cursor location.
To see the problem, start with a fresh document, single page, add a 3 x 3 table and deepen the rows a bit. Be sure to supply a file to insert, variable f. Select one of the cells, then run the code. This works correctly when the picture is inserted as an inline shape then immediately converted to a shape. That happens with this line:
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
However, the preferred solution would be to insert a Shape from the beginning with code something like this:
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
The picture appears, but usually not in the expected location. It could be placed into a different cell or somewhere outside the table.
Is the rng argument to Shapes.AddPicture being ignored or mangled somehow?
Experimenting some more with the 3 x 3 table - adding pictures then setting every possible WrapFormat.Type (there are 8 possible values), I see that:
for every WrapFormat.Type except wdWrapInLine, picture insertion works correctly as long as they are done from left to right on a table row, and;
for every WrapFormat.Type without exception, when the row is initially empty, pictures inserted in columns 2 or 3 appear one column to the left.
Making the picture smaller, such as setting h = .height * 0.5 and w = .width * 0.5, has no effect on placement.
Thanks very much for any insight or elucidation.
The main problem appears to be about the pictures inserting in the wrong column. This would be because the "focus point" (location of the Range) of an empty table cell has its starting point in the previous cell. Doesn't really make a lot of sense, but that's how Word works...
Try collapsing the Range to the End, rather than the Start (wdCollapseEnd) in this extract from your code:
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseEnd 'instead of wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With
In the end, selective usage of rng.collapse did the trick. I have yet to check whether this behaviour is the same in Word 2010 or 2016.
For the first shape anywhere in a table row, rng.collapse wdCollapseEnd.
For all subsequent shapes on that table row, rng.collapse wdCollapseBegin.
I used the following code to count up the shapes in table rows:
Dim numShapes() As Integer
Dim cel As Word.cell
ReDim numShapes(1 To Selection.Tables(1).Rows.Count)
For Each cel In Selection.Tables(1).Range.Cells
If cel.Range.ShapeRange.Count <> 0 Then
numShapes(cel.RowIndex) = numShapes(cel.RowIndex) + 1
End If
Next cel
and the check is simply
If numShapes(r) <> 0 Then
rng.collapse wdCollapseStart
Else
rng.collapse wdCollapseEnd
End If
where r is the row number from the first code example.
Initial experiments with merged cells suggest other problems...
I have an ActiveX listbox on an Excel 2007 worksheet. I want to populate it directly, not by pointing its RowSource property to a range, because there is no range that has the desired values.
The listbox's ColumnCount is set to 2.
I set ColumnWidths to "20;20", and now it returns:
20 pt;20 pt
So as far as I understand, two columns in the listbox should be available for writing, right?
Populating the first column is no problem:
activesheet.lstApplyCurves.List = array("Select All","Deselect All","aaa","bbb","ccc")
(or)
activesheet.lstApplyCurves.additem
activesheet.lstApplyCurves.List(0,0) = "Col1, Row1"
But how do I populate column 2? I get an error 380 ("Could not set the list property. Invalid property value.") on this:
activesheet.lstApplyCurves.List(0,1) = "Col2, Row1"
FWIW I've also tried this, but get the same error:
activesheet.lstApplyCurves.List(1,1) = "Col2, Row2"
So...how do I set values in the 2nd column?
UPDATE:
In addition to the answer below, FWIW I also found it's possible to assign a mulit-dimensional array to the List property, which is faster:
Dim ArrayToListbox() As Variant
ReDim ArrayToListbox(0 To 4, 0 To 2)
ArrayToListbox(0, 0) = "Select All"
ArrayToListbox(1, 0) = "Deselect All"
ArrayToListbox(2, 0) = "Row1-Col1"
ArrayToListbox(2, 1) = "Row1-Col2"
ArrayToListbox(2, 2) = "Row1-Col3"
ArrayToListbox(3, 0) = "Row2-Col1"
ArrayToListbox(3, 1) = "Row2-Col2"
ArrayToListbox(3, 2) = "Row2-Col3"
ArrayToListbox(4, 0) = "Row3-Col1"
ArrayToListbox(4, 1) = "Row3-Col2"
ArrayToListbox(4, 2) = "Row3-Col3" '"(" & Join(Array("a", "b", "c"), "|") & ")"
ActiveSheet.lstApplyCurves.Clear
ActiveSheet.lstApplyCurves.ColumnCount = 3
ActiveSheet.lstApplyCurves.List = ArrayToListbox
This works for me. If the below doesn't work on your system then delete the listbox and re-create it and then try this code again.
Private Sub CommandButton1_Click()
With ListBox1
.Clear
.ColumnCount = 2
For i = 1 To 2
.AddItem
.List(i - 1, 0) = "Col1, Row" & i
.List(i - 1, 1) = "Col2, Row" & i
Next i
End With
End Sub
I'm having some problems with the vba script below. It's pretty simple. It's meant to take the value of a dropdown list and respond based on a yes/no/null value in another sheet. The code works fine, except for that there is a problem in the vlookup lines that stops the script from running.
The first two vlookup lines return an "application defined or object defined error", and the third returns a "Data type mismatch" error. Each of the cells that the formulas refer to are formatted as text, so I'm not sure what the problem is... Any feedback would very helpful. Thank you!
If Not Intersect(Target, Range("countryProductCell")) Is Nothing Then
lastcolumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
cellRow = Target.Row
defaultCellColumn = 4
Dim countryIndex As Variant
countryIndex = Array(6, 6, 30, 21, 35, 29, 32, 20, 23, 18, 19, 34, 33, 22, 31, 26, 25, 27, 28, 7, 8, 15, 12, 10, 13, 11, 16, 17, 9)
i = 0
For Each countryCell In Range(Cells(cellRow, 5), Cells(cellRow, lastcolumn))
'If Default is selected
'If Not Target.Value = "(Select Title)" Then
'If Product is not selected
If countryCell.Value = "Use Default" Then
'Look Up Purchaseablility, Needs Array
If Not Application.VLookup(ActiveSheet.Cells(cellRow, defaultCellColumn), Sheets("Active Product Catalog").Range("E:AK"), countryIndex(i), False) = "Yes" Then
'If Not Purchaseable, Change Color
countryCell.Interior.ColorIndex = 3
End If
If Application.VLookup(ActiveSheet.Cells(cellRow, defaultCellColumn), Sheets("Active Product Catalog").Range("E:AK"), countryIndex(i), False) = "Yes" Then
'If Purchaseable, Change Color
countryCell.Interior.ColorIndex = 35
End If
Else
If Application.VLookup(ActiveSheet.Cells(cellRow, countryCell.Column), Sheets("Active Product Catalog").Range("E:AK"), countryIndex(i), False) = "Yes" Then
countryCell.Interior.ColorIndex = 35
End If
End If
'Else
'End If
i = i + 1
Next
End If
You define defaultCellColumn=4 but use undefined variable defaultCell in your first two formulas. It is a good idea to use Option Explicit at the start of your module - then this gets caught when you compile.
Not sure about the third error but your countryIndex array goes all the way to 35 which is more than the number of columns in E:AK. Recognize that VLOOKUP uses column offset relative to the range, not absolute column, for the third parameter (so 2=F in your case, and 35=AM which is outside of the range you specified and will throw an error.)
Data type mismatch error can be handled using the below method.
On Error Resume Next
Result = Application.VLookup(Cells(cellRow, countryCell.Column), Sheets("Active Product Catalog").Range("E:AK"), countryIndex(i), False)
If Result = "Error 2042" Then
Result = "Nothing Found"
Else
MsgBox Result
End If
On Error GoTo 0