I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows and apply hidden formatting on it but it selects only the first rows of the merged cell, not the whole row.
Below is the result that I am getting.
But I am seeking a result that will hide all content in 4 columns but I am unable to find a solution for the same.
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\New folder\Episode_0_intro_UEFA_v1_EN.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("Slide Notes")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Rows.Select
WrdApp.Selection.Font.Hidden = True
WrdApp.Selection.Range.HighlightColorIndex = wdBlue
'WrdApp.Selection.Range.Next.Rows.Select
'WrdApp.Selection.Font.Hidden = True
'WrdApp.Selection.Range.HighlightColorIndex = wdBlue
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where I am doing the issue so, I can rectify it?
Related
I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub
I have been working on this code that takes misspelled words from a document and then turns them into a table with all the misspelled words on one column. Then the words are spellchecked and the corrections appear on the other column. My code does everything that I want it to, however only the first word appears on each cell. What am I doing wrong?
Sub SuperSpellCheck()
Dim doc1 As Document
Dim doc2 As Document
Dim tb As Table
Set doc1 = ActiveDocument
Set doc2 = Documents.Add
doc1.Activate
Dim badw As Range
Dim rng As Range
Dim sugg As SpellingSuggestions
Dim sug As Variant
err = doc1.SpellingErrors.Count
For Each badw In doc1.SpellingErrors
doc2.Range.InsertAfter badw & vbCr
Next
doc2.Activate
Set tb = ActiveDocument.Content.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=1,
NumRows:=ActiveDocument.SpellingErrors.Count, AutoFitBehavior:=wdAutoFitFixed)
With tb
.Style = "Table Grid"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.Columns.Add
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
err2 = ActiveDocument.SpellingErrors.Count
i = 1
Set sugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If sugg.Count > 0 Then
Set sug = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter sug(1)
End If
End With
Next
End Sub
Not connected to your problem but you need to change these lines
Err = doc1.SpellingErrors.Count
err2 = ActiveDocument.SpellingErrors.Count
To:
Dim errors1 as Long, dim errors2 as Long
errors1 = doc1.SpellingErrors.Count
errors2 = doc2.SpellingErrors.Count
Err is an object in VBA that holds the errors generated by your code. You also haven't declared those variables. Add Option Explicit at the very top of your code module and you will be alerted to any undeclared variables. To turn this on automatically in future go to Tools | Options | Editor and ensure that Require Variable Declaration is checked.
I would change
Dim sugg As SpellingSuggestions
Dim sug As Variant
to
Dim docSugg As SpellingSuggestions
Dim rngSugg As SpellingSuggestions
Dim sug As SpellingSuggestion
This will make it clearer what each of these represents.
SpellingSuggestions is a collection of SpellingSuggestion objects so you can use sug to loop through the collection.
i = 1
Set sugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If sugg.Count > 0 Then
Set sug = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter sug(1)
End If
End With
Next
In this block of code you start off by setting the undeclared variable i to a value of 1, but you don't then increase that value. This will result in all your spelling suggestions being inserted in the same cell. Also, when you insert the spelling suggestion you only ever insert the first one as you don't have a means of looping through them. So I would rewrite this as:
i = 1
Set docSugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If docSugg.Count > 0 Then
Set rngSugg = .GetSpellingSuggestions
For Each sug In rngSugg
tb.Cell(i, 2).Range.InsertAfter sug
Next
End If
End With
i = i + 1
Next
EDIT: If you only want the first suggested spelling then use:
i = 1
Set docSugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If docSugg.Count > 0 Then
Set rngSugg = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter rngSugg(1)
End If
End With
i = i + 1
Next
In Word I have a document with multiple tables full of data. Hidden inside these cells (out of view but the data is there) is the Hex code of the color I want to shade the cells. I chose the hex value just because it's relatively short and it's a unique bit of text that won't be confused with the rest of the text in the cell.
I've found some code online to modify but I can't seem to make it work. It doesn't give any errors, just nothing happens. I feel like the problem is in searching the tables for the text value but I've spent hours on this and I think I've confused myself now!
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
If oRng = "CCFFCC" Then
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
End If
If oRng = "FFFF99" Then
oCel.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
Next
Next
End Sub
Thanks!
Edit:
I've also tried this code wit the same result of nothing happening:
Sub EachCellText()
Dim oCell As Word.Cell
Dim strCellString As String
For Each oCell In ActiveDocument.Tables(1).Range.Cells
strCellString = Left(oCell.Range.Text, _
Len(oCell.Range.Text) - 1)
If strCellString = "CCFFFF" Then
oCell.Shading.BackgroundPatternColor = wdColorLightGreen
If strCellString = "CCFFCC" Then
oCell.Shading.BackgroundPatternColor = wdColorLightYellow
If strCellString = "FFFF99" Then
oCell.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
End If
End If
Next
End Sub
Your Code is getting stuck nowhere. But you are checking the whole Cell Value against the Hex code, and this will not work since "blablabla FFFFFF" is never equal to "FFFFFF". So you have to check if the Hex code is in the Cell value:
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
Dim cellvalue As String
'check if Colorcode is in cell
If InStr(oRng, "CCFFCC") Then
'Set Cell color
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
'Remove Colorcode from Cell
cellvalue = Replace(oRng, "CCFFCC", "")
'load new value into cell
oRng = cellvalue
End If
Next
Next
End Sub
Now you just have to add all the colors you want to use (I would prefer a Select Case statement) and the code should work fine
I have an excel file with 160 rows and 2 columns of data - article name, price.
I also have a folder which contains photos for those articles.
The problem is that that picture names are not EXACTLY the same as the article names in my excel sheet.
For example in my sheet I have article name: "3714-012-P140" but in the folder it would be "3714-012-P140---****".
However, after the initial 3 blocks of code (3714; 012; P140 in the example) there will always show up only 1 picture in the search.
How would one go about selecting the picture with a wildcard in it?
Additionally, how would I go about locking the picture into a specific cell in excel? What I mean to say is that when I resize or delete some rows/columns, the pictures move along the cells they are assigned to.
Dim ws As Worksheet
Dim articleCode As String, _
findStr As String
Set ws = Workbooks(1).Worksheets(1)
For i = 1 to ws.UsedRange.Rows.Count
articleCode = ws.Cells(i,1)
findStr = 'some code
ActiveSheet.Pictures.Insert( _
"C:\...path...\" & findStr & ".jpg").Select
Next i
Edit: I need to insert the photo into a third column in each row of data.
Regarding "locking" a picture into a specific cell.
See here for info about how to link a shape to a cell.
Essentially you need to:
Position the picture over a cell. This can be done by setting the pictures (ie shape) .Top and .Left properties to be the same the cell you are linking the picture to.
Set the formula of the shape to equal the cell reference (this will also resize the shape to be the same size as the cell, and cause it to resize if the cell size is changed). See here
The code below taken from here will help you find a file in a folder that matches a "findstring". (It will need to be adapted!)
Sub FindPatternMatchedFiles()
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objRegExp As Object
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.pattern = ".*xlsx"
objRegExp.IgnoreCase = True
Dim colFiles As Collection
Set colFiles = New Collection
RecursiveFileSearch "C:\Path\To\Your\Directory", objRegExp, colFiles, objFSO
For Each f In colFiles
Debug.Print (f)
'Insert code here to do something with the matched files
Next
'Garbage Collection
Set objFSO = Nothing
Set objRegExp = Nothing
End Sub
Have your existing code call a function that accepts the name of the article (articleCode) and returns the path of the image file:
strImage = FindImage(articleCode)
If Len(strImage) > 0 Then ActiveSheet.Pictures.Insert strImage
Then you can write your function like so:
Function FindImage(strArticle As String) As String
Dim objFile As Object
With CreateObject("Scripting.FileSystemObject")
For Each objFile In .GetFolder("c:\path\to\images").Files
If StrComp(Left$(objFile.Name, Len(strArticle)), strArticle, vbTextCompare) = 0 Then
' Found an image file that begins with the article code.
FindImage = objFile.Path
Exit Function
End If
Next
End With
End Function
The function below takes articleCode which is the name of the picture, row and column into which the picture should be input.
Function picInsert(articleCode As String, row As Integer, column As Integer)
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim ws As Worksheet
Set ws = Workbooks(1).Worksheets(2) 'your worksheet where the pictures will be put
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("...path...")
i = 1
For Each objFile In objFolder.Files
If objFile.name Like (articleCode & "*") Then 'finds a picture with similar name to the one searched
With ActiveSheet.Pictures.Insert(objFile.Path)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 5
.Height = 15
End With
.Left = ActiveSheet.Cells(row, column).Left
.Top = ActiveSheet.Cells(row, column).Top
.Placement = 1 'locks the picture to a cell
End With
End If
i = i + 1
Next objFile
End Function
This is a test sub with which I tried the function above. Basically a simple loop which goes over the rows, takes the articleCode from first column and inputs a picture into third column using the function above.
Public Sub test()
Dim ws As Worksheet
Dim i As Integer
Dim articleCode As String
Set ws = Workbooks(1).Worksheets(2)
For i = 1 To ws.UsedRange.Rows.Count
articleCode = ws.Cells(i, 1)
Call picInsert(articleCode, i, 3)
Next i
End Sub
I have in excess of 300 word documents that include word tables, and I have been trying to write a VBA script for excel to extract the information I need, and I am completely new to Visual Basic. I need to copy the file name to the first cell, and the following cells to contain the information I am trying to extract, followed by the next file name, looping on until all word documents have been searched and extracted. I have tried multiple different ways, but the closest code I can find is as follows. It works to pull part numbers, but not descriptions. It also pulls extraneous information that doesn't need to be there, but I can work around that information if it is a necessary hazard.
I have an example word file (replaced sensitive information with other information), but I am not sure how to attach the word document or jpegs of page 1 and 2 of the word document. I know it would be beneficial if you could see it, so please let me know how to get it on here or to you so you can see it.
So to re-iterate:
I need the file name in the first cell (A1)
I need a certain cell out of table 3 from a word document to excel
If at all possible, I need descriptions in column B (B2:B?) and
mixture of letters and numbers in column C (C2:C?), then on the next
line down, the next file name (A?), and continue to repeat. If you
have any ideas, or suggestions, please let me know. And if I can't
post the picture, or the actual sample document, I am willing to
email, or any other means necessary to get help on this.
Here is the code I have been trying to manipulate. I found it and it was for a first and last row of a form, and I tried to get it to work, for my purposes to no avail:
Sub GetTablesFromWord()
'this Excel file must be in
'the same folder with the Word
'document files that are to be'processed.
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim wTable As Word.Table
Dim wCell As Word.Cell
Dim basicPath As String
Dim fName As String
Dim myWS As Worksheet
Dim xlCell As Range
Dim lastRow As Long
Dim rCount As Long
Dim cCount As Long
Dim RLC As Long
Dim CLC As Long
basicPath = ThisWorkbook.Path & Application.PathSeparator
'change the sheet name as required
Set myWS = ThisWorkbook.Worksheets("Sheet1")
'clear any/all previous data on the sheet myWS.Cells.Clear
'"open" Word Set wApp = CreateObject("Word.Application")
'get first .doc file name in the folder
'with this Excel file
fName = Dir(basicPath & "*.doc*")
Do While fName <> ""
'this puts the filename into column A to
'help separate the table data in Excel
myWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = _
"FILE: [" & fName & "]"
'open the Word file
wApp.Documents.Open basicPath & fName
Set wDoc = wApp.Documents(1)
'if there is a table in the
'Word Document, work with it
If wDoc.Tables.Count > 0 Then
Set wTable = wDoc.Tables(3)
rCount = wTable.Rows.Count
cCount = wTable.Columns.Count
For RLC = 1 To rCount
lastRow = myWS.Range("A" & Rows.Count).End(xlUp).Row + 1
For CLC = 1 To cCount
'if there are merged cells in the
'Word table, an error will be
'generated - ignore the error,
'but also won't process the data
On Error Resume Next
Set wCell = wTable.Cell(RLC, CLC)
If Err <> 0 Then
Err.Clear
Else
If CLC = 1 Then
Set xlCell = myWS.Range("A" & lastRow)
xlCell = wCell
Else
Set xlCell = myWS.Range("B" & lastRow)
xlCell = wCell
End If
End If
On Error GoTo 0
Next
Next
Set wCell = Nothing
Set wTable = Nothing
End If ' end of wDoc.Tables.Count test
wDoc.Close False
Set wDoc = Nothing
fName = Dir()
' gets next .doc* filename in the folder
Loop wApp.Quit
Set wApp = Nothing
MsgBox "Task Completed"
End Sub
This code loops through all of the .docx files contained within a folder, extracts data into your spreadsheet, closes the word document, and moves onto the next document. The name of the word document gets extracted into Column A, and a value from within the 3rd table in the document is extracted into Column B. This should be a good starting point for you to build upon.
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