I am writing some code in VBA in word and I would like to get the position of first borderline of the table as shown in this image
As seen in the above image, i would like to equalize the first table margin and second table margin (not sure if "margin" is the right word). The intention is to make the first table and second table column widths equal and combine them, merging them into one table. The word document has about 20 separate table and hence i would like to combine all of them into one single table. Please note that the empty tables that you see above has data removed to preserve confidential information.
What I have tried so far:
Public Sub CorrectTables()
Dim mainTable As Table
Dim secondTable As Table
Dim firstColWidth As Integer
Dim secondColumnWidth As Integer
Dim thirdColumnWidth As Integer
Dim fourthColumnWidth As Integer
Dim fiftColumnWidth As Integer
'Get current table
Set mainTable = ActiveDocument.Tables(1)
**firstColMarginPos = mainTable.LeftPadding** This is where i need some help to set the position
firstColWidth = mainTable.Columns(1).Width
secondColumnWidth = mainTable.Columns(2).Width
thirdColumnWidth = mainTable.Columns(3).Width
fourthColumnWidth = mainTable.Columns(4).Width
fiftColumnWidth = mainTable.Columns(5).Width
Dim currentTableCount As Integer
While ActiveDocument.Tables.Count <> 1
currentTableCount = ActiveDocument.Tables.Count
Set secondTable = ActiveDocument.Tables(2)
secondTable.LeftPadding = firstColMarginPos
secondTable.Columns(1).Width = firstColWidth
secondTable.Columns(2).Width = secondColumnWidth
secondTable.Columns(3).Width = thirdColumnWidth
secondTable.Columns(4).Width = fourthColumnWidth
secondTable.Columns(5).Width = fiftColumnWidth
Selection.Tables(1).Select
Selection.Collapse WdCollapseDirection.wdCollapseEnd
While (ActiveDocument.Tables.Count - currentTableCount = 0)
Selection.Delete Unit:=wdCharacter, Count:=1
Wend
Wend
End Sub
I figured out the answer. For the first table, i am able to get the indentation:
firstColMarginPos = mainTable.Rows.LeftIndent
Then i am able to use it to set the value for the second table:
secondTable.Rows.SetLeftIndent LeftIndent:=firstColMarginPos, RulerStyle:=wdAdjustFirstColumn
Related
Please refer my image, So you may get id MY Data source field
ea about my question,
column A field have 20k values rows, I want to Create blank row after data move to column-wise,( blank rows count=column wise count)
please give me solution vb MY Data source field
VBA or any formula MY DATA SOURCE IMAGE
Try this code
Sub Test()
Dim myAreas As Areas
Dim i As Long
Dim c As Long
Application.ScreenUpdating = False
Set myAreas = Columns(1).SpecialCells(2, 1).Areas
c = 1
For i = 1 To myAreas.Count
c = c + 1
Cells(myAreas(i)(1).Row, c).Resize(myAreas(i).Count).Value = myAreas(i).Value
Next i
Application.ScreenUpdating = True
End Sub
I have a document which is separated by section breaks.
Within each section I may have zero or one column breaks.
I want to extract the text from the first column of each section that contains 2 columns, like so:
For Each oSec In ActiveDocument.Sections
iSectionStart = oSec.Range.Start
iSectionEnd = oSec.Range.End
i = oSec.PageSetup.TextColumns.Count
If (2 = i) Then
' Update the range to only contain the text in textcolumn 1
' then select and copy it to a destination string
End If
Next oSec
However, the TextColumns object does not seem to have a method for returning the column contents.
TextColums.Count is actually not specified by the number of Column Breaks. You can have 2 columns (i.e. TextColumns.Count = 2) without a single Column Break.
If you for instance create a new document, fill it with random text by typing
=Rand(100)
and hit enter and select Two Columns from the Layout Tab. You will notice that you get two columns over 8 pages or so where none of the pages have Column Breaks.
The Office Object Model does not provide with an option to automatically select a specific column on a specifice page within a section. If the document actually has Column Breaks you can use the Find option to find the Column Break and from there select the Range from the start of the page to the start of the Column Break character that you just found using the Find option. Not a trivial thing to do as you can see.
Since the column break marker is represented by the ASCII value 14, all I had to do was look at each word in the section until I found the expected marker
Sub ExtractColumnText()
'
' On pages with no columns, the text is copied to both output files
' On pages with two columns, the column1 text is copied to "C:\DocTemp\Italian.doc"
' and column2 text is copied to "C:\DocTemp\English.doc"
'
Dim DestFileNum1 As Long
Dim DestFileNum2 As Long
Dim strDestFile1 As String
Dim strDestFile2 As String
Dim strCol1 As String
Dim strCol2 As String
Dim i As Integer
Dim oSec As Section
Dim oRngCol1 As Range
Dim oRngCol2 As Range
Dim oRngWord As Range
strDestFile1 = "C:\DocTemp\Italian.doc" 'Location of external file
DestFileNum1 = FreeFile()
strDestFile2 = "C:\DocTemp\English.doc" 'Location of external file
DestFileNum2 = DestFileNum1 + 1
Open strDestFile1 For Output As DestFileNum1
Open strDestFile2 For Output As DestFileNum2
For Each oSec In ActiveDocument.Sections
Set rngWorking = oSec.Range.Duplicate
Set oRngCol1 = rngWorking.Duplicate
oRngCol1.End = rngWorking.End - 1 ' exclude the page break
Set oRngCol2 = oRngCol1.Duplicate
If 2 <= oSec.PageSetup.TextColumns.Count Then
'examine each word in the section until we switch columns
For Each rngWord In rngWorking.Words
' 14 = column break marker
If 14 = AscW(rngWord.Text) Then
oRngCol1.End = rngWord.Start
oRngCol2.Start = rngWord.End
GoTo Xloop
End If
Next rngWord
End If
Xloop:
oRngCol1.Select
Print #DestFileNum1, oRngCol1.Text
oRngCol2.Select
Print #DestFileNum2, oRngCol2.Text
Next oSec
Close #DestFileNum1
Close #DestFileNum2
MsgBox "Done!"
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 have a dated CS degree so I understand the basics of VB but I don't write macros very often and need help solving a particular condition. (...but I understand functions and object oriented programming)
Assume the following:
- Column A contains reference ID's in alphanumeric form, sorted alphabetically.
- Column B contains strings of text, or blanks.
I'm trying to write a macro that automatically removes any extra rows for each unique reference number based on the contents of the "Notes" in column B. The problem is that if column A has multiple instances of a unique ref number, I need to identify which row contains something in column B. There is one catch: it is possible that the reference number has nothing in column B and should be retained.
To explain further, in the following screenshot I would need to:
Keep the yellow highlighted rows
Delete the remaining rows
I tried to show various configurations of how the report might show the data using the brackets on the right and marked in red. Its difficult to explain what I'm trying to do so I figured a picture would show what I need more clearly.
This task is making the report very manual and time consuming.
it's pretty simple
you just go throug the rows and check whether this row needs to be deleted, an earlier row with this id needs to be deleted or nothing should happen.
in my example i mark these rows and delete them in the end.
Sub foo()
Dim rngSelection As Range
Dim startingRow As Integer
Dim endRow As Integer
Dim idColumn As Integer
Dim noteColumn As Integer
Dim idValuableRow As New Dictionary
Dim deleteRows As New Collection
Set rngSelection = Selection
startingRow = rngSelection.Row
endRow = rngSelection.Rows.Count + startingRow - 1
idColumn = rngSelection.Column
noteColumn = idColumn + 1
For i = startingRow To endRow
currentID = Cells(i, idColumn)
If idValuableRow.Exists(currentID) Then
If Trim(idValuableRow(currentID)("note")) <> "" And Trim(Cells(i, noteColumn)) = "" Then
deleteRows.Add i
ElseIf idValuableRow(currentID)("note") = "" And Trim(Cells(i, noteColumn)) <> "" Then
deleteRows.Add idValuableRow(currentID)("row")
idValuableRow(currentID)("row") = i
idValuableRow(currentID)("note") = Cells(i, noteColumn)
End If
Else
Dim arr(2) As Variant
idValuableRow.Add currentID, New Dictionary
idValuableRow(currentID).Add "row", i
idValuableRow(currentID).Add "note", Cells(i, noteColumn)
End If
Next i
deletedRows = 0
For Each element In deleteRows
If element <> "" Then
Rows(element - deletedRows & ":" & element - deletedRows).Select
Selection.Delete Shift:=xlUp
deletedRows = deletedRows + 1
End If
Next element
End Sub
it could look something like this. the only thing you need is to add Microsoft Scripting Runtime in Tools/References
I've looked all over the place and tried various things. It's been assumed that it can't be done. So I'm going to try here and see if anybody else has had any luck.
Is there any way to get the height of a table row in Word when the row's HeightRule is set to wdRowHeightAuto?
Alternatively, if there's a way to get the cell's height instead, I'll accept that as a solution since you can calculate the row's height by finding the row's biggest cell.
It's possible to find the row height with Range.Information(). The following snippet doesn't work for the last row in a table or the last row on a page
Dim Tbl as Table
Dim RowNo as Integer
Dim RowHeight as Double
' set Tbl and RowNo to the table and row number you want to measure
RowHeight=Tbl.Rows(RowNo+1).Range.Information(wdVerticalPositionRelativeToPage) _
- Tbl.Rows(RowNo).Range.Information(wdVerticalPositionRelativeToPage)
This returns the height of the row in points by calculating the difference in position between the selected row and the following one.
I have a routine which works in all cases and returns the height in points of the second and subsequent lines in a cell, i.e. a single-line cell returns 0. (I use this in an application which reduces the font size in certain cells to fit the text on one line.)
Dim Doc As Document
Dim Tbl As Table
Dim Pos As Long
Dim RowNo As Integer
Dim ColNo As Integer
Dim CellHeight As Single
' set Doc, Tbl, RowNo and Colno to the document,table and row number you want to
' measure or provide a cell's range if you prefer
Pos = Tbl.Cell(RowNo, ColNo).Range.End - 1 ' last character in cell
CellHeight = Doc.Range(Pos, Pos).Information(wdVerticalPositionRelativeToTextBoundary)
How about cheating?
Dim tbl As Word.Table
Dim r As Row
Dim c As Cell
Set tbl = ActiveDocument.Tables(1)
For Each r In tbl.Rows
iHeight = r.HeightRule
r.HeightRule = 1
Debug.Print r.Height
r.HeightRule = iHeight
Next
I tried the above and found that changing the HeightRule changes the height of the row, which given I am trying to "freeze" the height on what appears in my table beforehand, makes nonsense of the above.
For rows which are empty or contain a single paragraph of unwrapped text in a consistent paragraph format adding up the font size, para before and after can work as follows:
Set r = c.Row
With r
If .HeightRule <> wdRowHeightExactly Then
.HeightRule = wdRowHeightExactly
Set p = c.Range.ParagraphFormat
.Height = c.BottomPadding + c.TopPadding + p.SpaceBefore + p.SpaceAfter + p.LineSpacing
End If
End With