I have a word file and I want to delete some pages in it. I use this Kutools codes for deleting
Sub DeletePagesInDoc()
Dim xRange As Range
Dim xPage As String
Dim xDoc As Document
Dim xArr
Dim I, xSplitCount As Long
Application.ScreenUpdating = False
Set xDoc = ActiveDocument
xPage = InputBox("Enter the page numbers of pages to be deleted: " & vbNewLine & _
"use comma to separate numbers", "KuTools for Word", "")
xArr = Split(xPage, ",")
xPageCount = UBound(xArr)
For I = xPageCount To 0 Step -1
Selection.GoTo wdGoToPage, wdGoToAbsolute, xArr(I)
xDoc.Bookmarks("\Page").Range.Delete
Next
Application.ScreenUpdating = True
End Sub
Some pages are deleted but some pages aren't. The word gives me this error The range cannot be deleted. Why I get this error?
Related
I have multiple word documents in a folder.
What I really want is to list the document names and check whether these docs incude some specified words.
I create two word documents for example to explain.
There are two documents, Doc A and Doc B, in a folder.
I want to list the file name Doc A and Doc B in the excel column A.
After listing the doc name in column A, I want to check whether specified words "classification" and "Statistics" are in the docs.
If these specified words in the document, it will mark in the excel. Please see below picture for the result I want.
I provide the code in the following:
Option Explicit
Private xRow As Long
Sub Get_MAIN_File_Names()
Dim fso As FileSystemObject
Dim xDirect As String
Dim xRootFolder As Folder
Dim DrawingNumb As String
Dim RevNumb As String
Dim rootFolderStr As String
Set fso = New FileSystemObject
xRow = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Main File"
.Show
'PROCESS ROOT FOLDER
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
Set xRootFolder = fso.GetFolder(xDirect)
ProcessFolder fso, xRootFolder
End If
End With
End Sub
Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
Dim xFiles As Files
Dim xFile As File
Dim xSubFolders As Folders
Dim xSubFolder As Folder
Dim xFileName As String
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
strFile = Dir(xFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=xFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set xFiles = xFolder.Files
'Adding Column names
Cells(1, "A").Value = "Document Name"
Cells(1, "B").Value = "classification"
Cells(1, "C").Value = "Statistics"
'LOOPS THROUGH EACH FILE NAME IN FOLDER
For Each xFile In xFiles
'EXTRACT INFORMATION FROM FILE NAME, this part may not add
xFileName = xFile.Name
Set Docs = objWordDocument.Content
With Docs.Find
.ClearFormatting
.Text = "classification"
Wrap:=wdFindContinue
End With
With Docs.Find
.ClearFormatting
.Text = "Statistics"
Wrap:=wdFindContinue
End With
'INSERT INFO INTO EXCEL
ActiveCell.Offset(xRow, 0) = xFileName
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
xRow = xRow + 1
With objWordDocument
.Close
End With
Next xFile
Set xSubFolders = xFolder.SubFolders
For Each xSubFolder In xSubFolders
ProcessFolder fso, xSubFolder
Next xSubFolder
End Sub
Based on above code, it fails.
I think the problem is With Docs.Find.....; however, I'm not really sure about it.
Moreover, I do not know how to do this part.
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
Can any one help me edit the code?
Maybe this code will help you out, it does:
Assume you got a activesheet setup with the three headers there
Loop through .docx files in specified folder
Checks wordrange for specified tekst
Returns true or false and puts found or not found in appropriate cell
Sub LoopWordDocs()
Dim FLDR As String
Dim wDoc As Word.Document
Dim wRNG As Word.Range
Dim LR As Long, COL As Long
Dim WS As String
Dim wAPP As Word.Application
Dim WordWasNotRunning As Boolean
On Error Resume Next
Set wAPP = GetObject(, "Word.Application")
If Err Then
Set wAPP = New Word.Application
WordWasNotRunning = True
End If
On Error GoTo Err_Handler
WS = ThisWorkbook.ActiveSheet.Name
FLDR = "U:\Test\" 'Change directory accordingly
aDoc = Dir(FLDR & "*.docx") 'Change docx to .doc if you need
Do While aDoc <> ""
Set wDoc = Documents.Open(Filename:=FLDR & aDoc)
LR = Sheets(WS).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(WS).Cells(LR, 1) = aDoc
Set wRNG = wDoc.Range
For COL = 2 To 3 'It will loop through B1 and C1 to check if present in text
With wRNG.Find
.Text = Sheets(WS).Cells(1, COL).Text
.MatchCase = False
.MatchWholeWord = True
If wRNG.Find.Execute = True Then
Sheets(WS).Cells(LR, COL) = "V" 'Change V to your liking
Else
Sheets(WS).Cells(LR, COL) = "X" 'Change X to your liking
End If
End With
Next COL
wDoc.Close SaveChanges:=True
aDoc = Dir
Loop
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordWasNotRunning Then
wAPP.Quit
End If
End Sub
Note: You'll have to turn on Microsoft Word 14.0 Object Library for this to work
Hopefully a quick one.
I through together a macro for splitting a word file (merged file of letters) into individual pdfs and naming them based on a ref number included in the file.
'Start split
For Each sec In ActiveDocument.Sections
Set rng = sec.Range 'Range of section
SecText = sec.Range.Text 'All text within section
SecTextPosition = InStr(SecText, "Our ref: ") 'Position of "Out ref: " within the section
strCDRS = Mid(SecText, (SecTextPosition + 9), 16) 'Retrieved CDRS reference
If sec.Index < ActiveDocument.Sections.Count Then
rng.MoveEnd wdCharacter, -1 'drop trailing section break
End If
rng.ExportAsFixedFormat strFolder & "\" & Replace(strCDRS, "/", "-") & "-" & strLetterType & ".pdf", wdExportFormatPDF
Set rng = Nothing
Next sec
This works perfectly when embedded in the word file. However, when embedding in the excel file and referencing the document, I get a type mismatch on the:
Set rng = sec.Range 'Range of section
Look at the value of sec.Range, it looks fine, so it appears to be something to do with the rng range object. Am I missing something obvious?
Full draft code as follows:
Sub SplitExport()
Dim sec As Section
Dim rng As Range
Dim strSplitFile As String
Dim strCDRS As String
Dim strLetterType As String
Dim strFolder As String
Dim SecText As String
Dim SecTextPosition As Long
Dim strfldr As FileDialog
Dim strfile As FileDialog
Dim WordFile As Word.Document
'Set word application
Set wordapp = CreateObject("word.Application")
'Pick file to split
Set strfile = Application.FileDialog(msoFileDialogFilePicker)
With strfile
.Title = "Select a file to split"
.AllowMultiSelect = False
.Show
strSplitFile = .SelectedItems(1)
End With
'Check if a file was selected
If strSplitFile = "" Then
MsgBox "Cannot proceed without file selection", vbOKOnly + vbCritical, "Error"
Exit Sub
End If
'Set Letter Type String
strLetterType = InputBox("Please enter letter code...")
If strLetterType = "" Then
MsgBox "Cannot proceed without letter code", vbOKOnly + vbCritical, "Error"
Exit Sub
End If
'Set folder to save PDFs to
Set strfldr = Application.FileDialog(msoFileDialogFolderPicker)
With strfldr
.Title = "Select a folder to save split files"
.AllowMultiSelect = False
.Show
strFolder = .SelectedItems(1)
End With
'Check a folder was selected
If strFolder = "" Then
MsgBox "Cannot proceed without folder selection", vbOKOnly + vbCritical, "Error"
Exit Sub
End If
'Open file to split
Set WordFile = wordapp.Documents.Open(strSplitFile)
WordFile.Activate
'Start split
For Each sec In ActiveDocument.Sections
Set rng = sec.Range 'Range of section
SecText = sec.Range.Text 'All text within section
SecTextPosition = InStr(SecText, "Our ref: ") 'Position of "Out ref: " within the section
strCDRS = Mid(SecText, (SecTextPosition + 9), 16) 'Retrieved reference
If sec.Index < ActiveDocument.Sections.Count Then
rng.MoveEnd wdCharacter, -1 'drop trailing section break
End If
rng.ExportAsFixedFormat strFolder & "\" & Replace(strCDRS, "/", "-") & "-" & strLetterType & ".pdf", wdExportFormatPDF
Set rng = Nothing
Next sec
End Sub
Apologies for wasting anyone's time reading this - I haven't changed the reference from section to Word.section, etc.
I will leave up as a testament to my muppetry.
I am looking for a way to get the table of contents (not created but headings available) from word and store the chapter numbers and headings on Excel. Is there a method using Excel VBA to take those headings from word doc to excel? I have searched for this but everybody suggest using paste special however I want it automated since the data from TOC is sorted into a different table in Excel afterwards.
Sub importwordtoexcel()
MsgBox ("This Macro Might Take a While, wait until next Message")
Application.ScreenUpdating = False
Sheets("Temp").Cells.Clear
'Import all tables to a single sheet
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
If wdDoc.Tables.Count = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
Else
jRow = 0
For TableNo = 1 To wdDoc.Tables.Count
With .Tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
jRow = jRow + 1
For iCol = 1 To .Columns.Count
On Error Resume Next
Sheets("Temp").Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
On Error GoTo 0
Next iCol
Next iRow
End With
jRow = jRow + 1
Next TableNo
End If
End With
Set wdDoc = Nothing
'Takes data from temp to RTM_FD
Dim nRow As Long
Dim mRow As Long
Dim Temp As Worksheet
Dim RTM As Worksheet
Set Temp = Sheets("Temp")
Set RTM = Sheets("RTM_FD")
mRow = 16
For nRow = 1 To Temp.Rows.Count
If Temp.Cells(nRow, 1).Value = "Position" Or Temp.Cells(nRow, 1).Value = "" Then
Else
RTM.Cells(mRow, 1).Value = Temp.Cells(nRow, 1)
RTM.Cells(mRow, 2).Value = Temp.Cells(nRow, 4)
RTM.Cells(mRow, 2).Font.Bold = False
RTM.Cells(mRow, 3).Value = Temp.Cells(nRow, 5)
RTM.Cells(mRow, 3).Font.ColorIndex = 32
If Temp.Cells(nRow, 3).Value = "P" Then
RTM.Cells(mRow, 9).Value = "X"
RTM.Cells(mRow, 9).Interior.ColorIndex = 44
ElseIf Temp.Cells(nRow, 3) = "Q" Then
RTM.Cells(mRow, 7).Value = "X"
RTM.Cells(mRow, 7).Interior.ColorIndex = 44
ElseIf Temp.Cells(nRow, 3) = "TA" Then
RTM.Cells(mRow, 8).Value = "X"
RTM.Cells(mRow, 8).Interior.ColorIndex = 44
Else
End If
mRow = mRow + 1
End If
Next nRow
Application.ScreenUpdating = True
MsgBox ("DONE")
Sheets("Temp").Cells.Clear
Dim SaveName As String
SaveName = InputBox("What Do You Want to Save the File As:")
ActiveWorkbook.SaveAs (SaveName)
MsgBox ("Your file is saved as " & SaveName)
MsgBox ("Please Accept Delete Operation")
Sheets("Temp").Delete
ActiveWorkbook.Save
End Sub
One way to get section headings without creating a TOC is by iterating with the selection object, using Selection.Goto. The folowing example prints all the sections headings in a document to the immediate window. I am sure you can adapt the concept to your code.
Sub PrintHeadings()
Dim wrdApp As Word.Application
Dim wrdDoc As Document
Dim Para As Paragraph
Dim oldstart As Variant
Set wrdApp = CreateObject("Word.Application") 'open word
Set wrdDoc = wrdApp.Documents.Open("C:\sample.docx", , True, False, , , , , , , , True) 'open file
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView 'avoids crashing if opens on read view
With wrdDoc.ActiveWindow.Selection
.GoTo What:=wdGoToHeading, which:=wdGoToFirst 'go to first heading
Do
Set Para = .Paragraphs(1) 'get first paragraph
Title = Replace(Para.Range.Text, Chr(13), "") 'gets title and remove trailing newline
Debug.Print Title, "pg. "; .Information(wdActiveEndAdjustedPageNumber) 'prints title and page to console
oldstart = .Start 'stores position
.GoTo What:=wdGoToHeading, which:=wdGoToNext 'go to next heading
If .Start <= oldstart Then Exit Do 'if looped around to first section (i.e. new heading is before old heading) we are done
Loop
End With
wrdDoc.Close
wrdApp.Quit
Set Para = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
I use early binding, so you will need to either add a reference to Word object model, or tweak the code to late binding (including finding out the numeric value of the enums).
I worked fine with My Chinese words documents, it may require to change some of the codes for different heading style.
If it won't work for you, I would love to have your words sample file and figure out why.
PS: The key point is to have the correct #OLE_LINK format.
My codes is as follows:
' Get your file and save in Range("A1")
Public Sub SelectAFile()
Dim intChoice As Integer
Dim strPath As String
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to sheet 1
Cells(1, 1) = strPath
End If
End Sub
' Main program start here
Sub genWordIndex()
Dim rng As Range
Dim r As Range
Dim PageName As String
Dim TestValue As String
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
Set rng = Range("A1") 'Selection
Call CleanOldText(1)
PageName = rng.text
Call ReadIndexFromWords3(PageName)
End Sub
Sub ReadIndexFromWords3(ByVal FileName As String)
'
' This is a common routine for handling open file
'
Dim WA As Object
Dim wdDoc As Word.Document
On Error Resume Next
Set WA = GetObject(, "Word.Application")
If WA Is Nothing Then
Set WA = CreateObject("Word.Application")
Set wdDoc = WA.Documents.Open(FileName)
Else
On Error GoTo notOpen
Set wdDoc = WA.Documents(FileName)
GoTo OpenAlready
notOpen:
Set wdDoc = WA.Documents.Open(FileName)
End If
OpenAlready:
wdDoc.Activate
'
' read index program start here。
'
Dim i As Integer: i = 2
Dim H_start, H_end, H_Caption, H_lvl, H_page As String
Dim H_txt As String
Dim Para As Paragraph
For Each Para In wdDoc.Paragraphs
Para.Range.Select
If Not Para.Range.Style Is Nothing Then
If IsMyHeadingStype(Para.Range.Style) = True Then
H_start = Para.Range.Start
H_end = Para.Range.End
H_txt = Para.Range.text
H_Caption = Para.Range.ListFormat.ListString
H_page = Para.Range.Information(wdActiveEndPageNumber)
Dim myLinkAddress As String
myLinkAddress = FileName & "#OLE_LINK" & i & vbTab & "1," & H_start & "," & H_end & ",2,," & H_txt
Application.ActiveWorkbook.Activate
ActiveSheet.Cells(i, 1).Select
Dim CapLen As Integer:
CapLen = Len(H_Caption) - 1
If CapLen < 0 Then CapLen = 0
ActiveSheet.Cells(i, 1) = Space(CapLen) & H_Caption & " " & H_txt
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:=myLinkAddress, SubAddress:="" 'TextToDisplay:=H_txt,
ActiveSheet.Cells(i, 2) = H_page
i = i + 1
End If
End If
Next
End Sub
'
' you may have to change your InStyle here
'
Function IsMyHeadingStype(ByVal InStyle As String) As Boolean
Dim rc As Boolean: rc = False
If InStr(InStyle, "標題 1") Or InStr(InStyle, "標題 2") Or InStr(InStyle, "標題 3") Then
rc = True
End If
IsMyHeadingStype = rc
End Function
' sub routine
Sub CleanOldText(ByVal col1 As Integer)
Dim i As Integer
Dim lastR As Integer
lastR = Cells(10000, col1).End(xlUp).Row
For i = 2 To lastR
Cells(i, col1).ClearContents
Cells(i, col1 + 1).ClearContents
Next i
End Sub
I'm getting the error
"error 424" - object required
on the marked line:
Sub CreateWordDocuments1()
Const FilePath As String = "D:\"
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("word.application")
wApp.Visible = True
Dim PersonCell As Range
'create copy of Word in memory
Dim PersonRange As Range
'create a reference to all the people
Range("A1").Select
Set PersonRange = Range( ActiveCell, ActiveCell.End(xlDown))
'for each person in list �
For Each PersonCell In PersonRange
'open a document in Word
Set wDoc = wApp.Documents.Open("D:\template.doc")
'go to each bookmark and type in details
CopyCell "FirstName", 1
'save and close this document
wDoc.SaveAs2 FilePath & "person " & PersonCell.Value & ".doc"
wDoc.Close
Next PersonCell
wApp.Quit
MsgBox "Created files in " & FilePath & "!"
End Sub
Sub CopyCell(BookMarkName As String, ColumnOffset As Integer)
'copy each cell to relevant Word bookmark
wApp.Selection.GoTo What:=-1, Name:="FirstName" ''' Error on this line
wApp.Selection.TypeText PersonCell.Offset(0, ColumnOffset).Value
End Sub
Also, I am trying for whole day to skip this error but I can't. I search for some alternatives such as XML maybe?
The issues with your initial code:
Main error: variable wApp exists in CreateWordDocuments1, but
not in CopyCell
Variable PersonCell exists in CreateWordDocuments1, but not in CopyCell (same as 1st)
CopyCell doesn't use parameter BookMarkName (not critical but made it redundant)
.
Edited code to accommodate multiple Word bookmarks in synch with Excel columns
Here is how all files are setup - column names in Excel represent Bookmark names in Word:
.
Option Explicit
Public Sub CreateWordDocuments()
Const FILE_PATH As String = "C:\Tmp\"
Const FILE_NAME As String = "Template"
Const FILE_EXT As String = ".doc"
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim totalRows As Long 'assumes all columns are the same size
Dim totalCols As Long 'assumes all rows are the same size
Dim person As Long 'Outer loop counter (all rows)
Dim personList As Variant 'All data: rows and columns, without header row
Dim bookmark As Long 'Inner loop counter (all columns)
Dim bookmarks As Variant 'All bookmarks, from the header row
Set wApp = CreateObject("Word.Application")
wApp.Visible = False
'We're working in Sheet1, and data starts in its first cell (A1)
With ThisWorkbook.Worksheets(1)
With .UsedRange
bookmarks = .Rows(1).Value2 'get all column headers
totalRows = .Rows.Count
totalCols = .Columns.Count
End With
'all data without the header row -------------------------------------
personList = .Range(.Cells(2, 1), .Cells(totalRows, totalCols)).Value2
End With
For person = 1 To totalRows - 1 'each row (after header)
'Open Word Template file
Set wDoc = wApp.Documents.Open(FILE_PATH & FILE_NAME & FILE_EXT)
For bookmark = 1 To totalCols 'each column
With wApp.Selection
'bookmark name from header row
.GoTo What:=wdGoToBookmark, Name:=bookmarks(1, bookmark)
'enter data for each bookmark
.TypeText personList(person, bookmark)
End With
Next 'next column \ bookmark
With wDoc 'sava and close the new Word file (person name in column 1)
.SaveAs FILE_PATH & "Person " & personList(person, 1) & " " & personList(person, 2) & FILE_EXT
.Close
End With
Next 'next row
wApp.Quit
Set wDoc = Nothing
Set wApp = Nothing
MsgBox "Created " & totalRows - 1 & " files in " & FILE_PATH
End Sub
Need help to modify this VBA code to read multiple tables from a Word document. It only reads one table, but I would like to import more than one into the same Excel sheet.
Sub ImportWordTables()
'Imports a table from Word document
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'number of tables in Word doc
Dim iTable As Integer 'table number index
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
TableNo = wdDoc.tables.Count
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & _
"Enter table number of table to import", "Import Word Table", "1")
End If
With .tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(iRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Next iCol
Next iRow
End With
End With
Set wdDoc = Nothing
End Sub
So this is the code, but it doesn't entirely answer my questions.
I just need the tables from the pdf.
Sub Imp_Into_XL(PDF_File As String, Each_Sheet As Boolean)
'This procedure get the PDF data into excel by following way
'1.Open PDF file
'2.Looping through pages
'3.get the each PDF page data into individual _
sheets or single sheet as defined in Each_Sheet Parameter
Dim AC_PD As Acrobat.AcroPDDoc 'access pdf file
Dim AC_Hi As Acrobat.AcroHiliteList 'set selection word count
Dim AC_PG As Acrobat.AcroPDPage 'get the particular page
Dim AC_PGTxt As Acrobat.AcroPDTextSelect 'get the text of selection area
Dim WS_PDF As Worksheet
Dim RW_Ct As Long 'row count
Dim Col_Num As Integer 'column count
Dim Li_Row As Long 'Maximum rows limit for one column
Dim Yes_Fir As Boolean 'to identify beginning of page
Li_Row = Rows.Count
Dim Ct_Page As Long 'count pages in pdf file
Dim i As Long, j As Long, k As Long 'looping variables
Dim T_Str As String
Dim Hld_Txt As Variant 'get PDF total text into array
RW_Ct = 0 'set the intial value
Col_Num = 1 'set the intial value
Application.ScreenUpdating = False
Set AC_PD = New Acrobat.AcroPDDoc
Set AC_Hi = New Acrobat.AcroHiliteList
'set maximum selection area of PDF page
AC_Hi.Add 0, 32767
With AC_PD
'open PDF file
.Open PDF_File
'get the number of pages of PDF file
Ct_Page = .GetNumPages
'if get pages is failed exit sub
If Ct_Page = -1 Then
MsgBox "Pages Cannot determine in PDF file '" & PDF_File & "'"
.Close
GoTo h_end
End If
'add sheet only one time if Data retrive in one sheet
If Each_Sheet = False Then
Set WS_PDF = Worksheets.Add(, Worksheets(Sheets.Count))
WS_PDF.Name = "PDF3Text"
End If
'looping through sheets
For i = 1 To Ct_Page
T_Str = ""
'get the page
Set AC_PG = .AcquirePage(i - 1)
'get the full page selection
Set AC_PGTxt = AC_PG.CreateWordHilite(AC_Hi)
'if text selected successfully get the all the text into T_Str string
If Not AC_PGTxt Is Nothing Then
With AC_PGTxt
For j = 0 To .GetNumText - 1
T_Str = T_Str & .GetText(j)
Next j
End With
End If
If Each_Sheet = True Then
'add each sheet for each page
Set WS_PDF = Worksheets.Add(, Worksheets(Sheets.Count))
End If
'transfer PDF data into sheet
With WS_PDF
If Each_Sheet = True Then
.Name = "Page-" & i
'get the PDF data into each sheet for each PDF page
'if text accessed successfully then split T_Str by VbCrLf
'and get into array Hld_Txt and looping through array and fill sheet with PDF data
If T_Str <> "" Then
Hld_Txt = Split(T_Str, vbCrLf)
For k = 0 To UBound(Hld_Txt)
T_Str = CStr(Hld_Txt(k))
If Left(T_Str, 1) = "=" Then T_Str = "'" & T_Str
.Cells(k + 1, 1).Value = T_Str
Next k
Else
'information if text not retrive from PDF page
.Cells(1, 1).Value = "No text found in page " & i
End If
Else
'get the pdf data into single sheet
If T_Str <> "" Then
Hld_Txt = Split(T_Str, vbCrLf)
Yes_Fir = True
For k = 0 To UBound(Hld_Txt)
RW_Ct = RW_Ct + 1
'check begining of page if yes enter PDF page number for any idenfication
If Yes_Fir Then
RW_Ct = RW_Ct + 1
.Cells(RW_Ct, Col_Num).Value = "Text In Page - " & i
RW_Ct = RW_Ct + 2
Yes_Fir = False
End If
'check for maximum rows if exceeds start from next column
If RW_Ct > Li_Row Then
RW_Ct = 1
Col_Num = Col_Num + 1
End If
T_Str = CStr(Hld_Txt(k))
If Left(T_Str, 1) = "=" Then T_Str = "'" & T_Str
.Cells(RW_Ct, Col_Num).Value = T_Str
Next k
Else
RW_Ct = RW_Ct + 1
.Cells(RW_Ct, Col_Num).Value = "No text found in page " & i
RW_Ct = RW_Ct + 1
End If
End If
End With
Next i
.Close
End With
Application.ScreenUpdating = True
MsgBox "Imported"
h_end:
Set WS_PDF = Nothing
Set AC_PGTxt = Nothing
Set AC_PG = Nothing
Set AC_Hi = Nothing
Set AC_PD = Nothing
End Sub
You can use this to do something with each table in the document:
Dim oTbl As Table
For Each oTbl In ActiveDocument.Tables
' Do something
Debug.Print oTbl.Columns.Count & " " & oTbl.Rows.Count
Next
You'll need to figure out how you want the user to specify which table/tables to work with.
Something like this, perhaps:
Sub UserChosenTables()
Dim oTbl As Table
Dim sTemp As String
Dim aTables() As String
Dim x As Long
sTemp = InputBox("Which tables", "Select tables")
If Len(sTemp) = 0 Then ' user entered nothing
Exit Sub
End If
aTables = Split(sTemp, ",")
' of course you'll want to add more code to CYA in case the user
' asks for a table that's not there or otherwise enters something silly.
' You might also want to let them enter e.g. ALL if they want you to do all of them
' (but don't know how many there are)
For x = LBound(aTables) To UBound(aTables)
Set oTbl = ActiveDocument.Tables(CLng(aTables(x)))
' do [whatever] with table here
Debug.Print oTbl.Columns.Count & " " & oTbl.Rows.Count
Next
End Sub