I need a macro to input angle values from modeling in a drafting table. Please help...
See the image
we need more infos.. below if it can help you :
Sub test()
Dim d As DrawingDocument = CATIA.ActiveDocument 'need to be a CATDrawing opened
Dim t As DrawingTable = d.Sheets.ActiveSheet.Views.ActiveView.Tables.Item(1)
Dim i As Integer = 1
Dim p As Product = CATIA.Documents.Item("Part1.CATPart").product 'i let you find your Part
For Each MyParam As Parameter In p.Parameters
If MyParam.Name Like "*Angle.*" Then 'i let you find a way to get your names
t.SetCellString(i, 1, MyParam.ValueAsString)
i += 1
End If
Next
End Sub
check my website : https://www.catiavb.net/
Related
I'm looking for a way to have three different colors in the same line chart of a diagram in Excel, depending on the values themselves or where they are from (from which sheet f.e).
Till now, I have the following code:
Sub ChangeColor()
Dim i As Integer
Dim IntRow As Integer
Dim r As Range
ActiveSheet.ChartObjects("Cash").Activate
ActiveChart.SeriesCollection(1).Select
IntRow = ActiveChart.ChartObjects("Cash").Count
For i = 2 To IntRow
Set r = Cells(2, i)
If r.Value < 3000 Then
Selection.Border.ColorIndex = 5
Else
Selection.Border.ColorIndex = 9
End If
Next
End Sub
However, the if statement is not considered and the color of the whole line changes only whenever I change the first ColorIndex. I have no idea, how to color parts of the line depending on the values in the underlying table.
Moreover, by defining IntRow as ActiveChart.ChartObjects("Cash").Count I'm not able to get the length of my array. This problem can be solved by manual counting and declaring IntRow as an Integer, however, the version above seems nicer (if that is possible of course).
I appreciate any help! Thank you.
Alexandra
You can read the values directly from the chart series:
Sub ChangeColor()
Dim cht As Chart, p As Point, s As Series
Dim i As Integer
Dim numPts As Long
'access the chart directly - no select/activate required
Set cht = ActiveSheet.ChartObjects("Cash").Chart
'reference the first series
Set s = cht.SeriesCollection(1)
'how many points in the first series?
numPts = s.Points.Count
'loop over the series points
For i = 1 To numPts
Set p = cht.SeriesCollection(1).Points(i)
p.Border.ColorIndex = IIf(s.Values(i) < 3000, 5, 9)
Next
End Sub
I am a very new user and am trying to open up three workbooks and copy the same cell range of the three books to three different ranges in a fourth book.
I have done a good amount of troubleshooting but I cannot find anything to help fix this.
The problem points to Sub WeeklyLeagues()
Option Explicit
Sub WeeklyLeagues()
Dim x_both As workbook_both
Dim x_sf As workbook_sf
Dim x_mf As workbook_mf
Dim y As workbook_final
Set x_both = Workbooks.Open("Sheet1 Path")
Set x_sf = Workbooks.Open("Sheet2 Path")
Set x_sf = Workbooks.Open("Sheet3 Path")
Set y = Workbooks.Open("Sheet4 Path")
x_both.Sheets("Request 4 Rank 1").Range("A2:E18").Copy
y.Sheets("Source").Range("M2:Q18").PasteSpecial
x_sf.Sheets("Request 4 Rank 1").Range("A2:E18").Copy
y.Sheets("Source").Range("A2:E18").PasteSpecial
x_mf.Sheets("Request 4 Rank 1").Range("A2:E18").Copy
y.Sheets("Source").Range("G2:k18").PasteSpecial
'Close x:
x_both.Close
x_sf.Close
x_mf.Close
End Sub
I'm writing a macro to read the below Email:
Start Date: July-07-2016
Name Accept Approved
John Yes No
Peter No No
I'm good with search the word "Start date" and get the next 13 character to copy and paste that in a text file. But my problem is the next part is in a Table format. So when I'm searching for the name "John" and trying to copy the next 10 Characters. It doesn't work.
Is there a way to search for the word "Accept" and get the First Row data(Which will be No) and then Second Row data(Which will be No)? Is that possible?
This EMail's table will have only 2 Rows. So, I don't need any dynamic way to get the data. Can someone guide me?
I've tried searching the internet first, but the solutions are too huge for me to understand. Is there any simple way?
I have even tried the solution give here: How to read table pasted in outlook message body using vba? but that method works when the body has ONLY TABLE. But my EMail will have text as well as table.
I've never actually programmed in vba, but I think I can help (a bit) nevertheless.
In the answer on the post you linked to, there is the line
Set msg = ActiveExplorer.Selection.item(1)
I think you can change this to something like
Set msg = Right(ActiveExplorer.Selection.item(1), 25)
to get rid of the text before the table (I got the Right part from here: http://www.exceltrick.com/formulas_macros/vba-substring-function/, but it should also work in Outlook).
This way, you run the code on the table itself instead of on the whole message.If there is also text after the table, it might be more difficult, but you might get that done by searching for the table ending.
I hope this helps!
Attempt 2
After some searching and thinking, I came up with the idea to get the html of the message and use that to parse the table (Ok, not really, I got it from the comments here: http://www.codeproject.com/Questions/567073/Howplustoplusrecognizeplusandplusreadplustableplus). Based on that and other sources, it is possible to write a code that gets the table from an email.
I've written some code that might work, but I couldn't test it as I do not have Outlook. Also, this is my first time writing vba, so there may be a lot of syntax errors (and the code is ugly).
Sub GetTable()
Dim msg As Outlook.mailItem
Dim html As String
Dim tableBegin As String
Dim tableEnd As String
Dim posTableBegin As Long
Dim posTableEnd As Long
Dim table As String
Dim rowBegin As String
Dim rowEnd As String
Dim rowCount As Long
Dim columnBegin As String
Dim columnBeginLen As Long
Dim columnEnd As String
Dim posRowBegin As Long
Dim posRowEnd As Long
Dim values As String(0, 3)
Dim beginValue0 As Long
Dim beginValue1 As Long
Dim beginValue2 As Long
Dim EndValue0 As Long
Dim EndValue1 As Long
Dim EndValue2 As Long
' Get the message and the html
Set msg = ActiveExplorer.Selection.item(1)
html = msg.HTMLbody
' Get the begin and end positions of the table (within the html)
tableBegin = "<table>"
tableEnd = "</table>"
posTableBegin = InStr(1, html, tableBegin)
posTableEnd = InStr(posTableBegin, html, tableEnd)
' Get the html table
table = Mid(html, posTableBegin + Len(tableBegin), posTableEnd - posTableBegin - Len(tableBegin))
' Set the variables for the loop
rowBegin = "<tr>"
rowEnd = "</tr>"
rowCount = 0
columnBegin = "<td>"
columnBeginLen = Len(columnBegin)
columnEnd = "</td>"
' Loop trough all rows
posRowBegin = InStr(lastPos, table, rowBegin)
Do While posRowBegin != 0
' Get the end from the current row
posRowEnd = InStr(posRowBegin, table, rowEnd)
rowCount = rowCount + 1
' Make the array larger
ReDim Preserve values(rowCount + 1, 3)
' Get the contents from that row
row = Mid(table, posRowBegin + Len(rowBegin), posRowEnd - posRowBegin - Len(rowBegin))
' Get the three values from that row (name, Accept, Approved) and put it in the array
beginValue0 = InStr(1, row, columnBegin) + columnBeginLen
endValue0 = InStr(beginValue0, row, columnEnd)
beginValue1 = InStr(endValue0, row, columnBegin) + columnBeginLen
endValue1 = InStr(beginValue1, row, columnEnd)
beginValue2 = InStr(endValue1, row, columnBegin) + columnBeginLen
endValue2 = InStr(beginValue2, row, columnEnd)
values(rowCount, 0) = Mid(row, beginValue0, endValue0)
values(rowCount, 1) = Mid(row, beginValue1, endValue1)
values(rowCount, 2) = Mid(row, beginValue2, endValue2)
' Get the beginning of the next row
posRowBegin = InStr(lastPos, table, rowBegin)
Loop
' The values are now in the (double) array 'values'.
' values(0, [1-3]) contains the headers.
End Sub
As said before, the original idea came from http://www.codeproject.com/Questions/567073/Howplustoplusrecognizeplusandplusreadplustableplus. Additionally, I used Word VBA how to select text between two substrings and assign to variable? and the Microsoft documentation to write this.
While it is likely that the code does not work out of the box, I think it still gets the general idea (and some specifics) across, so that it can be used as a guide. I hope this is the solution you need!
You can actually use the Word Object Model to parse out the text from the table - assuming that the email is in HTML format.
Get a Word.Document object from the Inspector.WordEditor property and use Word objects and methods to get the text, like the following below example from MSDN. Just replace ActiveDocument with the variable you declare and set from WordEditor.
Sub ReturnCellContentsToArray()
Dim intCells As Integer
Dim celTable As Cell
Dim strCells() As String
Dim intCount As Integer
Dim rngText As Range
If ActiveDocument.Tables.Count >= 1 Then
With ActiveDocument.Tables(1).Range
intCells = .Cells.Count
ReDim strCells(intCells)
intCount = 1
For Each celTable In .Cells
Set rngText = celTable.Range
rngText.MoveEnd Unit:=wdCharacter, Count:=-1
strCells(intCount) = rngText
intCount = intCount + 1
Next celTable
End With
End If
End Sub
I am fairly new to VBA, I couldn't really find answer specific to my simple request (most answers were a lot more complicated....). I would like Cell E2 to populate with the result of the vlookup. Is there a simple way to do this?
Thanks and sorry if I failed to find a suitable answer..
Sub vlookup_customerror()
Worksheets("customerror").Activate
On Error GoTo Errormsg
Hobbyquery = Application.WorksheetFunction.VLookup(Range("E1"),
ActiveSheet.Range("A2:B5"), 2, 0)
Cells("E2").Value = Hobbyquery
GoTo ending
Errormsg: GoTo ending
ending: End Sub
Please try This: You can add error handler code also
Sub custom_error()
Dim result As Integer
Dim sheet As Worksheet
Set sheet = ActiveWorkbook.Sheets("customerror")
Name = sheet.Range("E1").Value
result = Application.VLookup(Name, sheet.Range("A2:B5"), 2, False)
sheet.Range("E2").Value = result
Debug.Print result
End Sub
If you have string data in Column B then change Dim result As String
EDIT : To cover the situation , if the lookup value is on other sheet as per
apprehension expressed by #MacroMarc. In that case please try This:
Sub custom_error_v2()
Dim result As Variant
On Error Resume Next
result = Application.WorksheetFunction.VLookup(Range("E1"), _
Worksheets("Sheet1").Range("A:C"), 2, False)
On Error GoTo 0
If IsEmpty(result) Then
MsgBox "Value not found!"
End If
Range("E2") = result
End Sub
Images of sample data are appended below.
Please make changes to sheet names as per your requirement.
I want to outline the chart data range source(s) in a table, in much the same way that the GUI will outline a range in blue if the chart data series is clicked. The user can choose various chart views and the range highlight colours for each data series need to match those displayed in the chart.
For the record, here are the methods I considered:
Parse the chart series values string and extract the data range
Do a lookup on a table that stores information on the ranges and the colours to be used
In the end I went with option 2 as is seemed easier to implement and to properly manage the colours I would probably have to store them for method 1 anyway, negating its benefits.
The highlight procedure is called from the Worksheet_Change event, a lookup is done on the chart name, the ranges and colours pulled from the table and then the cell formatting is carried out. The limitation of this method is that the range/colour data for each new chart view must be pre-calculated. This isn't much of a problem for my current implementation, but my be a limiting factor in future use where the charts might be more dynamic.
So although I've got a version of this working fine, I'm sure there must be a more elegant way of achieving this.
Any suggestions?
Edit:
OK, this seems to handle more cases better. The triggering code is the same, but here is new code for the module:
Function SeriesRange(s As Series) As Range
Dim sf As String, fa() As String
sf = s.Formula
sf = Replace(sf, "=SERIES(", "")
If sf = "" Then
Set SeriesRange = Nothing
Exit Function
End If
fa = Split(sf, ",")
Set SeriesRange = Range(fa(2))
End Function
Sub x(c As Chart)
Dim sc As Series
Dim sr As Range
If SeriesRange(c.SeriesCollection(1)) Is Nothing Then
Exit Sub
End If
Set sr = SeriesRange(c.SeriesCollection(1))
sr.CurrentRegion.Interior.ColorIndex = xlNone
For Each sc In c.SeriesCollection
If sc.Interior.Color > 1 Then
SeriesRange(sc).Interior.Color = sc.Interior.Color
ElseIf sc.Border.ColorIndex > 1 Then
SeriesRange(sc).Interior.Color = sc.Border.Color
ElseIf sc.MarkerBackgroundColorIndex > 1 And sc.MarkerBackgroundColorIndex < 57 Then
SeriesRange(sc).Interior.ColorIndex = sc.MarkerBackgroundColorIndex
ElseIf sc.MarkerForegroundColorIndex > 1 And sc.MarkerForegroundColorIndex < 57 Then
SeriesRange(sc).Interior.ColorIndex = sc.MarkerForegroundColorIndex
Else
MsgBox "Unable to determine chart color for data series " & sc.Name & " ." & vbCrLf _
& "It may help to assign a color rather than allowing AutoColor to assign one."
End If
Next sc
End Sub
/Edit
This is probably more barbaric than elegant, but I think it does what you want. It involves your first bullet point to get the range from the Series object, along with a sub to run through all the Series objects in the SeriesCollection for the chart. This is activated on Chart_DeActivate. Most of this code is jacked - see comments for sources.
In a module:
Function SeriesRange(s As Series) As Range
Dim sf As String, fa() As String
Dim i As Integer
Dim result As Range
sf = s.Formula
sf = Replace(sf, "=SERIES(", "")
fa = Split(sf, ",")
Set SeriesRange = Range(fa(2))
End Function
Sub x(c As Chart)
Dim sc As Series
Dim sr As Range
Set sr = SeriesRange(c.SeriesCollection(1))
sr.CurrentRegion.Interior.ColorIndex = xlNone
For Each sc In c.SeriesCollection
SeriesRange(sc).Interior.Color = sc.Interior.Color
Next sc
End Sub
In the ThisWorkbook object module:
' Jacked from C Pearson http://www.cpearson.com/excel/Events.aspx '
Public WithEvents CHT As Chart
Private Sub CHT_Deactivate()
x CHT
End Sub
Private Sub Workbook_Open()
Set CHT = Worksheets(1).ChartObjects(1).Chart
End Sub
Have you tried using Conditional Formatting?