Convert inch to mm using macro select Case in Word VBA - vba

Trying to get this macro to work in Word VBA. Any help to fix this would be greatly appreciated.
Sub ConvertToMM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim inch_in As Integer
Dim mm_out As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
inch_in = CVar(mm_out)
mm_out = “”
With wrdFind
Select Case inch_in
Case Is = 0.039
mm_out = “1MM”
Case Is = 0.059
mm_out = “1.5MM”
Case Is = 0.079
mm_out = “2MM”
Case Is = 0.118
mm_out = “3MM”
Case Is = 0.157
mm_out = “4MM”
Case Is = 0.236
mm_out = “6MM”
Case Is = 0.315
mm_out = “8MM”
Case Is = 0.394
mm_out = “10MM”
Case Is = 0.472
mm_out = “12MM”
End Select
End With
wrdRng.Text = mm_out
End Sub

Try using the next function, please:
Function InchToMM(i As Double) As String
InchToMM = Round(i * 25.4, 0) & "MM"
End Function
It can be called/tested with such a code:
Sub testConvertInchToMM()
Dim inc As String
inc = "0.039" 'use Find or whatever you want to determine it...
MsgBox InchToMM(CDbl(inc))
End Sub

First, do replace the smart quotes from Word with real double-quotes:
Set wrdFind = wrdRng.Find
inch_in = CVar(mm_out)
mm_out = ""
With wrdFind
Select Case inch_in
Case Is = 0.039
mm_out = "1MM"
Case Is = 0.059
mm_out = "1.5MM"
Case Is = 0.079
mm_out = "2MM"
Case Is = 0.118
mm_out = "3MM"
Case Is = 0.157
mm_out = "4MM"
Case Is = 0.236
mm_out = "6MM"
Case Is = 0.315
mm_out = "8MM"
Case Is = 0.394
mm_out = "10MM"
Case Is = 0.472
mm_out = "12MM"
End Select
End With
wrdRng.Text = mm_out
If that "doesn't work", consider a generic method for your task as found here:
Converting between meters and inches

Sub AutoOpen()
ConvertTO1MM
ConvertTO1_5MM
ConvertTO2MM
ConvertTO3MM
ConvertTO4MM
ConvertTO5MM
ConvertTO6MM
ConvertTO8MM
ConvertTO10MM
ConvertTO12MM
End Sub
Sub ConvertTO1MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.039"
SearchResult = .Execute
Select Case .Text
Case Is = 0.039
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO1_5MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.059"
SearchResult = .Execute
Select Case .Text
Case Is = 0.059
mm = Round(.Text * 25.4, 1) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO2MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.079"
SearchResult = .Execute
Select Case .Text
Case Is = 0.079
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO3MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.118"
SearchResult = .Execute
Select Case .Text
Case Is = 0.118
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO4MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.157"
SearchResult = .Execute
Select Case .Text
Case Is = 0.157
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO5MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.196"
SearchResult = .Execute
Select Case .Text
Case Is = 0.196
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO6MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.236"
SearchResult = .Execute
Select Case .Text
Case Is = 0.236
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO8MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.315"
SearchResult = .Execute
Select Case .Text
Case Is = 0.315
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO10MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.394"
SearchResult = .Execute
Select Case .Text
Case Is = 0.394
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub
Sub ConvertTO12MM()
Dim wrdFind As Find
Dim wrdRng As Range
Dim wrdDoc As Document
Dim mm As Variant
Set wrdDoc = Application.ActiveDocument
Set wrdRng = wrdDoc.Content
Set wrdFind = wrdRng.Find
With wrdFind
.Text = "0.472"
SearchResult = .Execute
Select Case .Text
Case Is = 0.472
mm = Round(.Text * 25.4, 0) & "MM"
End Select
End With
If SearchResult = True Then
wrdRng.Text = mm
End If
End Sub

Related

Extract Outlook UserDefinedProperties field

I add UserDefinedProperties in Outlook with the below code
Sub AddStatusProperties()
Dim objNamespace As NameSpace
Dim objFolder As Folder
Dim objProperty As UserDefinedProperty
Set objNamespace = Application.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
With objFolder.UserDefinedProperties
Set objProperty = .Add("MyNotes1", olText, 1)
End With
End Sub
The user can add a value to MyNotes1 field in any email.
Public Sub EditField()
Dim obj As Object
Dim objProp As Outlook.UserProperty
Dim strNote As String, strAcct As String, strCurrent As String
Dim propertyAccessor As Outlook.propertyAccessor
Set obj = Application.ActiveExplorer.Selection.Item(1)
On Error Resume Next
Set UserProp = obj.UserProperties.Find("MyNotes1")
If Not UserProp Is Nothing Then
strCurrent = obj.UserProperties("MyNotes1").Value
End If
Dim varArrayList As Variant
Dim varArraySelected As Variant
varArrayList = Array("value1", "value2", "value3")
varArraySelected = SelectionBoxMulti(List:=varArrayList, Prompt:="Select one or more values", _
SelectionType:=fmMultiSelectMulti, Title:="Select multiple")
If Not IsEmpty(varArraySelected) Then 'not cancelled
For i = LBound(varArraySelected) To UBound(varArraySelected)
If strNote = "" Then
strNote = varArraySelected(i)
Else
strNote = strNote & ";" & varArraySelected(i)
End If
Next i
End If
Set objProp = obj.UserProperties.Add("MyNotes1", olText, True)
objProp.Value = strNote
obj.Save
Err.Clear
Set obj = Nothing
End Sub
I need to extract all email properties including the values available under MyNotes field to Excel. How do I recall MyNotes1 values?
This is the Excel code. The part I miss is "myArray(6, i - 1) = item.?????".
Public Sub getEmails()
On Error GoTo errhand:
Dim outlook As Object: Set outlook = CreateObject("Outlook.Application")
Dim ns As Object: Set ns = outlook.GetNamespace("MAPI")
'This option open a new window for you to select which folder you want to work with
Dim olFolder As Object: Set olFolder = ns.PickFolder
Dim emailCount As Long: emailCount = olFolder.Items.Count
Dim i As Long
Dim myArray As Variant
Dim item As Object
ReDim myArray(6, (emailCount - 1))
For i = 1 To emailCount
Set item = olFolder.Items(i)
If item.Class = 43 And item.ConversationID <> vbNullString Then
myArray(0, i - 1) = item.Subject
myArray(1, i - 1) = item.SenderName
myArray(2, i - 1) = item.To
myArray(3, i - 1) = item.CreationTime
myArray(4, i - 1) = item.ConversationID
myArray(5, i - 1) = item.Categories
'myArray(6, i - 1) = item.?????
End If
Next
With ActiveSheet
.Range("A1") = "Subject"
.Range("B1") = "From"
.Range("C1") = "To"
.Range("D1") = "Created"
.Range("E1") = "ConversationID"
.Range("F1") = "Category"
.Range("G1") = "MyNote"
.Range("A2:G" & (emailCount + 1)).Value = TransposeArray(myArray)
End With
Exit Sub
errhand:
Debug.Print Err.Number, Err.Description
End Sub
You already have code that retrieves that property
Set UserProp = item.UserProperties.Find("MyNotes1")
If Not UserProp Is Nothing Then
myArray(6, i - 1) = UserProp.Value
End If

Why code prints an error like "Object required"?

i don't know why my code prints an error like "Object required" in line stpos = ARange.End
Public Function CreateNewWordDocument(TempPath)
Dim wd
Set App = CreateObject("Word.Application")
App.Visible = True
Set wd = App.Documents.Add(TempPath)
Set CreateNewWordDocument = wd
End Function
Public Function AddNewParagraphRange(ARange)
Dim NewParagraph
Dim NewRange
Dim I As Integer
I = ARange.Paragraphs.Count
ARange.InsertParagraphAfter
Set NewRange = ARange.Paragraphs(I).Range
NewRange.StartOf wdWord, wdMove
Set AddNewParagraphRange = NewRange
End Function
Public Sub RunForword(CurDBPath)
Dim R As Range
Set R = doc.Range
Dim aPart1
Dim aPart2
Dim aPart3
Set aPart1 = AddNewParagraphRange(R)
Set aPart2 = AddNewParagraphRange(R)
Set aPart3 = AddNewParagraphRange(R)
End Sub
Public Function WriteParagraphLn(ARange, text, StyleName) As Range
Dim stpos As Long
stpos = ARange.End
If Len(ARange) <= 2 Then
ARange.InsertAfter text
Else
ARange.InsertParagraphAfter
ARange.Document.Range(ARange.End, ARange.End + 1).Style = wdNormalStyleName
ARange.InsertAfter text
End If
If StyleName <> "" Then _
ARange.Document.Range(stpos, ARange.End).Style = StyleName
Set WriteParagraphLn = ARange.Document.Range(stpos, ARange.End)
End Function
Sub Creat_doc()
Dim TempPath As String
Dim doc
Set doc = CreateNewWordDocument(TempPath)
With doc
.PageSetup.TopMargin = CentimetersToPoints(2)
.PageSetup.BottomMargin = CentimetersToPoints(1.5)
End With
doc.Activate
Dim TextLine As String
TextLine = WriteParagraphLn("", "hello world", "Times New Roman")
doc.TypeText text:=TextLine
End Sub

Tables overwritten when exporting multiple tables from excel to word

I am trying to use VBA to create a Word document with multiple tables each on a new page (using a loop) compiled with cell information from Excel.
So far everything works fantastically except after inserting the first table it is replaced by the second table, then the third table replaces the second, and so on. What I am left with is only the last created table.
I'm not sure how to cause a new table to be created instead of replacing the previously created table.
Screen shot of Excel table
Sub Export_to_Word()
'(1) Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdCell As Word.Cell
Dim wdTabl As Word.Table
Dim wdRange As Word.Range
'(2) Excel objects
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim strValue As String
Dim i As Integer
Dim x As Integer
'For assiging integer value to calculate number of table rows
Dim ARows As Integer
Dim BRows As Integer
Dim CRows As Integer
Dim DRows As Integer
'For copying question part as a value in the excel sheet
Dim QueNum As Variant
Dim PartA As Variant
Dim PartB As Variant
Dim PartC As Variant
Dim PartD As Variant
'For copying the question in the excel sheet
Dim QueA As Variant
Dim QueB As Variant
Dim QueC As Variant
Dim QueD As Variant
'For copying question part as a value in the excel sheet
Dim MarkA As Variant
Dim MarkB As Variant
Dim MarkC As Variant
Dim MarkD As Variant
'For copying the answers in the excel sheet
Dim AnsA As Variant
Dim AnsB As Variant
Dim AnsC As Variant
Dim AnsD As Variant
'For copying the header values in the excel sheet
Dim CandCode As Variant
Dim AnPath As Variant
Dim Logo As Variant
Dim EngNam As Variant
Dim EngTex As Variant
Dim FreNam As Variant
Dim FreTex As Variant
'(4) Initialize the Excel objects
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
'(5)Create table in excel before copying to word
'Create Word file.
Set wdApp = New Word.Application
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
'(5a)Enter excel values into header
With wdDoc.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = CandCode & vbCr & vbCr & AnPath
.Headers(wdHeaderFooterPrimary).Range.Font.Name = "Arial"
.Headers(wdHeaderFooterPrimary).Range.Font.Size = 7
.Headers(wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
'(5b)Start of new cycle for loop
For i = 4 To 6
'(5c) Equate cell values to the the variables defined under Excel objects (Part 2). N.B in equation "Cells(3,i) 3= row number and i=column number
ARows = wsSheet.Cells(3, i).Value
BRows = wsSheet.Cells(7, i).Value
CRows = wsSheet.Cells(11, i).Value
DRows = wsSheet.Cells(15, i).Value
QueNum = wsSheet.Cells(1, i).Value
PartA = wsSheet.Range("A2").Value
PartB = wsSheet.Range("A6").Value
PartC = wsSheet.Range("A10").Value
PartD = wsSheet.Range("A14").Value
QueA = wsSheet.Cells(2, i).Value
QueB = wsSheet.Cells(6, i).Value
QueC = wsSheet.Cells(10, i).Value
QueD = wsSheet.Cells(14, i).Value
MarkA = wsSheet.Cells(4, i).Value
MarkB = wsSheet.Cells(8, i).Value
MarkC = wsSheet.Cells(12, i).Value
MarkD = wsSheet.Cells(16, i).Value
AnsA = wsSheet.Cells(5, i).Value
AnsB = wsSheet.Cells(9, i).Value
AnsC = wsSheet.Cells(13, i).Value
AnsD = wsSheet.Cells(17, i).Value
CandCode = wsSheet.Range("V24").Value
AnPath = wsSheet.Range("V25").Value
Logo = wsSheet.Range("V26").Value
EngNam = wsSheet.Range("V27").Value
EngTex = wsSheet.Range("V28").Value
FreNam = wsSheet.Range("V29").Value
FreTex = wsSheet.Range("V30").Value
'(5d)Creates variables that identifes location of each of the rows with the question part
TotRows = ARows + BRows + CRows + DRows + 5
QuesA_row = 2
QuesB_row = ARows + 3
QuesC_row = ARows + BRows + 4
QuesD_row = ARows + BRows + CRows + 5
'(5e)Create Word table
Set wdRange = wdDoc.Range
wdDoc.Tables.Add wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow
Set wdTabl = wdDoc.Tables(1)
'(5f)Edit Table
With wdTabl
.ApplyStyleHeadingRows = False
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = False
.ApplyStyleLastColumn = True
.ApplyStyleRowBands = False
.ApplyStyleColumnBands = False
'Changes font of table
.Range.Font.Name = "Arial"
.Range.Font.Size = "10"
'Changes spacing of lines in table to single
.Range.ParagraphFormat.SpaceBeforeAuto = False
.Range.ParagraphFormat.SpaceBefore = 8
.Range.ParagraphFormat.SpaceAfterAuto = False
.Range.ParagraphFormat.SpaceAfter = 0
.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
.Range.ParagraphFormat.PageBreakBefore = False
'Adjust column widths
.Columns(1).SetWidth ColumnWidth:=20, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=23, RulerStyle:=wdAdjustNone
.Columns(3).SetWidth ColumnWidth:=400, RulerStyle:=wdAdjustNone
.Columns(4).SetWidth ColumnWidth:=11, RulerStyle:=wdAdjustNone
.Columns(5).SetWidth ColumnWidth:=40, RulerStyle:=wdAdjustNone
'Shading for marks column & borders
.Borders.Enable = False
.Columns(5).Shading.BackgroundPatternColor = wdColorGray20
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Borders(wdBorderLeft).Color = wdColorBlack
.Columns(5).Borders(wdBorderLeft).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderLeft).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Borders(wdBorderRight).Color = wdColorBlack
.Columns(5).Borders(wdBorderRight).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderRight).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Borders(wdBorderBottom).Color = wdColorBlack
.Columns(5).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Cells(1).Borders(wdBorderBottom).Color = wdColorBlack
.Columns(5).Cells(1).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(1).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
'Underlines for questions
.Columns(3).Cells.Borders.InsideLineStyle = wdLineStyleSingle 'Adds bottom border to all cells in column 3
.Columns(3).Cells(1).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(1).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(1).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesA_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesB_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesC_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).Color = wdColorWhite 'Removes bottom border
.Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(QuesD_row).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
.Columns(3).Cells(TotRows).Borders(wdBorderBottom).Color = wdColorBlack 'Adds border to bottom row of column
.Columns(3).Cells(TotRows).Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
.Columns(3).Cells(TotRows).Borders(wdBorderBottom).LineWidth = Options.DefaultBorderLineWidth
'Enter Data into table
.Columns(1).Cells(2).Range.Text = QueNum & "."
.Columns(2).Cells(QuesA_row).Range.Text = PartA
.Columns(2).Cells(QuesB_row).Range.Text = PartB
.Columns(2).Cells(QuesC_row).Range.Text = PartC
.Columns(2).Cells(QuesD_row).Range.Text = PartD
.Columns(3).Cells(QuesA_row).Range.Text = QueA
.Columns(3).Cells(QuesB_row).Range.Text = QueB
.Columns(3).Cells(QuesC_row).Range.Text = QueC
.Columns(3).Cells(QuesD_row).Range.Text = QueD
.Columns(5).Cells(1).Range.Text = "Marks"
.Columns(5).Cells(QuesA_row).Range.Text = MarkA
.Columns(5).Cells(QuesB_row).Range.Text = MarkB
.Columns(5).Cells(QuesC_row).Range.Text = MarkC
.Columns(5).Cells(QuesD_row).Range.Text = MarkD
'Modifying marks column
.Columns(5).Cells(1).Range.Font.Bold = True 'Modifys "marks" cell
.Columns(5).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(1).Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom
.Columns(5).Cells(QuesA_row).Range.Font.Bold = True
.Columns(5).Cells(QuesA_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesA_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Cells(QuesB_row).Range.Font.Bold = True
.Columns(5).Cells(QuesB_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesB_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Cells(QuesB_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(QuesB_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Cells(QuesC_row).Range.Font.Bold = True
.Columns(5).Cells(QuesC_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesC_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Cells(QuesC_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(QuesC_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
.Columns(5).Cells(QuesD_row).Range.Font.Bold = True
.Columns(5).Cells(QuesD_row).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Columns(5).Cells(QuesD_row).Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
.Columns(5).Borders(wdBorderTop).Color = wdColorBlack
.Columns(5).Cells(QuesD_row).Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
.Columns(5).Cells(QuesD_row).Borders(wdBorderTop).LineWidth = Options.DefaultBorderLineWidth
'Adjusts text alignment in question column
.Columns(3).Cells.VerticalAlignment = wdCellAlignVerticalBottom
' Exit table and insert page break so next table starts at beginning of page
With wdRange
.Collapse Direction:=wdCollapseEnd
.InsertParagraphAfter
.InsertBreak Type:=wdPageBreak
.Collapse Direction:=wdCollapseEnd
End With
End With
Next i
'(7)Identifies all numbered words and replaces them with all caps bold
Dim A(10) As String
A(1) = "one"
A(2) = "two"
A(3) = "three"
A(4) = "four"
A(5) = "five"
A(6) = "six"
A(7) = "seven"
A(8) = "eight"
A(9) = "nine"
A(10) = "ten"
Set wdRange = ActiveDocument.Content
With wdRange
For x = 1 To 10
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
.Find.Replacement.Font.Bold = True
With .Find
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Replacement.Font.Bold = True
.Replacement.Font.Allcaps = True
wdRange.Find.Execute FindText:=A(x), ReplaceWith:=A(x), Format:=True, _
Replace:=wdReplaceAll
End With
Next x
End With
'(8)Null out the variables.
Set wdCell = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Set wdRange = Nothing
Set wdTabl = Nothing
'(9) Adds message box to show complete
MsgBox "Success! The exam questions are complete!", vbInformation
End Sub
This stripped-down version worked for me:
Sub Export_to_Word()
Dim wdApp As Word.Application, i As Long, wdDoc As Word.Document
Dim wdCell As Word.Cell, wdTabl As Word.Table, wdRange As Word.Range
Dim wbBook As Workbook, wsSheet As Worksheet
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
Set wdApp = New Word.Application
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
For i = 1 To 5
wdDoc.Paragraphs.Add
Set wdRange = ActiveDocument.Paragraphs.Last.Range
Set wdTabl = wdDoc.Tables.Add(wdRange, NumRows:=5, NumColumns:=5, _
DefaultTableBehavior:=wdWord8TableBehavior, _
AutoFitBehavior:=wdAutoFitWindow)
With wdTabl
.Borders.Enable = True
.Columns(1).Cells(1).Range.Text = "First"
.Columns(5).Cells(5).Range.Text = "Last"
End With
Next i
End Sub
You set up only one table.
'(5e)Create Word table
Set wdRange = wdDoc.Range
wdDoc.Tables.Add wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow
Set wdTabl = wdDoc.Tables(1)
Change code.
'(5e)Create Word table
Set wdRange = wdDoc.Range
Set wdTabl = wdDoc.Tables.Add(wdRange, NumRows:=(TotRows), NumColumns:=5, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitWindow)
'Set wdTabl = wdDoc.Tables(1)

Stop searching on found

I have a application that searches a .xls document. The document is 60000 rows. What I am trying to make it do is, stop searching when the result is found. Currently it all works, but it scans the rest of the 59999 rows.
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet1 As Excel.Worksheet
Dim rng As Excel.Range
Dim codeabc As String
Dim found As Boolean
Dim i As Integer
If AssociateID.Text = String.Empty Then
'popup.Close()
MsgBox("Please make sure 'Associate ID' is filled out")
Exit Sub
End If
xlApp = CreateObject("Excel.Application")
xlBook = xlApp.Workbooks.Open("G:\grps\every\People Report\HRIS Remedy Report.xls")
xlSheet1 = xlBook.Worksheets(1)
rng = xlSheet1.Range("a1:a60000")
codeabc = (AssociateID.Text)
found = False
For i = 1 To rng.Count
If rng.Cells(i).Value = codeabc Then
IDLabel.Text = AssociateID.Text
NameLabel.Text = (rng.Cells(i).offset(0, 1).value())
DepartmentLabel.Text = (rng.Cells(i).offset(0, 3).value())
PositionLabel.Text = (rng.Cells(i).offset(0, 2).value())
found = True
End If
Next i
If Not found Then
MsgBox("Associate ID: " & AssociateID.Text & " is not found. Please check the ID and try again")
AssociateID.Clear()
End If
'popup.Close()
xlBook.Close()
Fix from Plutonix that worked. Thanks!
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet1 As Excel.Worksheet
Dim rng As Excel.Range
Dim codeabc As String
Dim found As Boolean
Dim i As Integer
If AssociateID.Text = String.Empty Then
'popup.Close()
MsgBox("Please make sure 'Associate ID' is filled out")
Exit Sub
End If
xlApp = CreateObject("Excel.Application")
xlBook = xlApp.Workbooks.Open("G:\grps\every\People Report\HRIS Remedy Report.xls")
xlSheet1 = xlBook.Worksheets(1)
rng = xlSheet1.Range("a1:a60000")
codeabc = (AssociateID.Text)
found = False
For i = 1 To rng.Count
If rng.Cells(i).Value = codeabc Then
IDLabel.Text = AssociateID.Text
NameLabel.Text = (rng.Cells(i).offset(0, 1).value())
DepartmentLabel.Text = (rng.Cells(i).offset(0, 3).value())
PositionLabel.Text = (rng.Cells(i).offset(0, 2).value())
found = True
xlBook.Close()
popup.Close()
--------> Exit Sub
End If
Next i
If Not found Then
MsgBox("Associate ID: " & AssociateID.Text & " is not found. Please check the ID and try again")
AssociateID.Clear()
End If
'popup.Close()
xlBook.Close()

Need to alter this code to extract all data from table instead of just one row

Hey everyone I found this awesome code that helped me get the loop I needed but I am trying to alter this to extract all the data from the word tables not just one row of the tables.. Any help would be great. I know it going to be a simple fix just haven't been able to get any to work on my own. Thanks
Sub wordScrape()
Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files
x = 1
For Each wd In objFiles
If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
sh1.Cells(x, 1) = wd.Name
sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)
'sh1.Cells(x, 3) = ....more extracted data....
x = x + 1
wrdDoc.Close
End If
Next wd
wordApp.Quit
End Sub`
Sub wordScrape()
Dim wd As New Word.Application
Dim wdDoc As Word.Document
Dim tbl As Word.Table
Dim sh1 As Worksheet
Dim x As Integer
Dim y As Integer
Dim s As String
Dim r As Range
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set r = sh1.Range("a1")
s = Dir(FolderName & "\*.doc*")
Do While s <> ""
If InStr(wd, "~") = 0 Then
Set wdDoc = wd.Documents.Open(FolderName & "\" & s, False, True, False)
For Each tbl In wdDoc.Tables
For x = 1 To t.Rows.Count
r = wdDoc.Name
For y = 1 To t.Columns.Count
r.Offset(0, y) = Application.WorksheetFunction.Clean(t.Cell(Row:=x, Column:=y).Range)
Next y
Set r = r.Offset(1, 0)
Next x
Next tbl
wdDoc.Close False
End If
s = Dir()
Loop
End Sub
Now, this is off the top of my head, it assumes a reference to word is set (tools,references in the VBE) and it crucially assumes that every table has no merged cells - if they do it will break. But it gets you started