I have a Word document that contains a table with 3 columns. I'm trying to create a macro that will open a pdf file (name stored in columns 2) at the page number in column 3.
I found a macro in Excel that will open it automatically when I select the page number cell, but nothing in Word. Lots of users are using the Word document and don't want to switch to Excel.
Best will be to activate the macro with a keybord shortcut and if in the table, it will open the file at the page specified in the row where the cursor is. If cursor is not in the table, an error could show.
Thanks.
[EDIT]
Here is the code for the Excel macro. Note that the Adobe Reader path and program is store in cell B1 and the file is in cell B2 in this example.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row > 4 And Target.Column = 1 And Target.Value > 0 Then
vAdobe = ActiveSheet.Cells(1, 2)
vDocument = ActiveSheet.Cells(2, 2)
vPage = Target.Value
result = Shell(vAdobe & " /A ""page=" & vPage & """ " & vDocument, vbNormalFocus)
End If
End Sub
Here's one way:
Sub OpenPDF()
Dim aRow As Row
Dim vDocument As String
Dim vPage As String
Dim vAdobe As String
Dim result As Long
vAdobe = <File path to Acrobat.exe here.>
If Selection.Information(wdWithInTable) = True Then
Set aRow = Selection.Range.Rows(1)
vDocument = Trim(Replace(Replace(aRow.Cells(2).Range.Text, "", ""), vbCr, ""))
vPage = Trim(Replace(Replace(aRow.Cells(3).Range.Text, "", ""), vbCr, ""))
result = Shell(vAdobe & " /A ""page=" & vPage & """ " & vDocument, vbNormalFocus)
Else: 'Some error message here.
End If
End Sub
You may need to play with those Replace methods; I found it necessary to remove some table characters that were appearing at the end of any text pulled from the table cell.
Another option that requires setting a reference can be found here: http://www.myengineeringworld.net/2012/07/vba-macro-to-open-pdf-file.html
Related
I am trying to write a macro whereby it checks all sheetnames for certain criteria (specifically here the inclusion of 'TUBA' in the name) and, if met, exports a range on those sheets to text files with the sheet name as filename. I am getting error 91: object variable or With block variable not set, and on debugging the If WS.name Like "TUBA*" Then line is highlighted. How can I fix this? The problematic code is below. I previously had success with almost the same code but without the If statement (shown in the second block below), so I assume its the way I am adding this in. If i need to set a variable, which one have i missed?
Sub ExportTubatoText()
Dim c As Range, r As Range
Dim output As String
Dim lngcount As Long
Dim WS As Worksheet
Dim Name As String
Dim strFolder As String
strFolder = GetFolder("L:TUBA\")
'\ dialog box opens in that folder as default
'strFolder = GetFolder("L:TUBA\")
If strFolder <> "" Then
MsgBox strFolder
End If
For Each sh In ThisWorkbook.Worksheets
'if worksheet has 'TUBA' in the title, then it is exported to text
If WS.Name Like "TUBA*" Then
output = ""
For Each r In sh.Range("F3:F200").Rows
For Each c In r.Cells
output = output & c.Value
Next c
output = output & vbNewLine
Next r
Name = sh.Name
Open strFolder & "\" & Name & ".txt" For Output As #1
Print #1, output
Close
End If
Next
End Sub
Successful code:
For Each sh In ThisWorkbook.Worksheets
output = ""
For Each r In sh.Range("O2:O500").Rows
For Each c In r.Cells
output = output & c.Value
Next c
output = output & vbNewLine
Next r
Name = sh.Name
Open strFolder & "\" & Name & ".txt" For Output As #1
Print #1, output
Close
Next
Try changing
If WS.Name Like "TUBA*" Then
to
If sh.Name Like "TUBA*" Then
Or change your For Each to WS in...
Note: this is just an idea and not an answer as #Rdster explain why your first code dos not work.
If you are working with only one column (like your both codes do) you can replace this part of your code:
For Each r In sh.Range("F3:F200").Rows
For Each c In r.Cells
output = output & c.Value
Next c
output = output & vbNewLine
Next r
with this line:
output = Join(Application.Transpose(sh.Range("F3:F200").Value), vbNewLine)
I am quite new in VBA and wrote a subroutine that copy-paste cells from one document into another one. Being more precise, I am working in document 1 where I have names of several product (all in column "A"). For these product, I need to look up certain variables (e.g. sales) in a second document.
The subroutine is doing the job quite nicely, but I want to use it as a funcion, i.e. I want to call the sub by typing in a cell "=functionname(productname)".
I am grateful for any helpful comments!
Best, Andreas
Sub copy_paste_data()
Dim strVerweis As String
Dim Spalte
Dim Zeile
Dim findezelle1 As Range
Dim findezelle2 As Range
Dim Variable
Dim Produkt
'Variable I need to copy from dokument 2
Variable = "frequency"
'Produkt I need to copy data from document 2
Produkt = Cells(ActiveCell.Row, 1)
'path, file and shhet of document 2
Const strPfad = "C:\Users\Desktop\test\"
Const strDatei = "Bezugsdok.xlsx"
Const strBlatt = "post_test"
'open ducument 2
Workbooks.Open strPfad & strDatei
Worksheets(strBlatt).Select
Set findezelle = ActiveSheet.Cells.Find(Variable)
Spalte = Split(findezelle.Address, "$")(1)
Set findezelle2 = ActiveSheet.Cells.Find(Produkt)
Zeile = Split(findezelle2.Address, "$")(2)
'copy cell that I need
strZelle = Spalte & Zeile 'Zelladresse
strVerweis = "'" & strPfad & "[" & strDatei & "]" & strBlatt & "'!" & strZelle
'close document 2
Workbooks(strDatei).Close savechanges:=False
With ActiveCell
.Formula = "=IF(" & strVerweis & "="""",""""," & strVerweis & ")"
.Value = .Value
End With
End Sub
Here is an example to create a function that brings just the first 3 letters of a cell:
Public Function FirstThree(Cell As Range) As String
FirstThree = Left(Cell.Text, 3)
End Function
And using this in a Excel worksheet would be like:
=FirstThree(b1)
If the sub works fine and you just want to make it easier to call you can add a hotkey to execute the Macro. In the developer tab click on Macros then Options. You can then add a shortcut key (Crtl + "the key you want" it can be a shortcut key already used like C, V, S, but you will lose those functions (Copy, Paste Save, Print)
enter image description here
Below is the code so far
I often times have to check if a Purchase Order has been saved in a directory, there could be hundreds of purchase orders listed in Excel.
As the Workbook changes, so often does the filepath.
As such, I would like to make a function that asks for a cell value that contains a string for the filepath, and then a a cell for the PO #.
I'm a little stumped on how best to past information from the Excel sheet. I need a cell reference for the filepath to the directory, and a cell reference for the PO #.
I've been able to make this work with a subroutine, that is what is posted below. This is the third VBA Program I've worked on, please let me know if there is more legwork I should do before posting this:
Dim directory As String
Dim TempfileName As String
Dim i As Long
Dim x As Long
Sub Check_PO()
x = 2
Application.ScreenUpdating = False
For x = 2 To 673
While Cells(x, 14) = 0
x = x + 1
Wend
i = Cells(x, 14)
TempfileName = "\\network\file\name\here\" & "*" & i & "*.pdf"
directory = Dir(TempfileName, vbNormal)
While directory <> ""
Cells(x, 18) = "Matched"
directory = Dir
Wend
Next x
End Sub
Here's a simple UDF:
Public Function HaveReport(fPath As String, fileName As String)
HaveReport = IIf(Dir(fPath & fileName, vbNormal) <> "", _
"Matched", "Not Matched")
End Function
Usage:
I've looked and found a little help so far but I'm stuggling with the for each logic for this Excel Macro I'm trying to make.
Basically I have 4 columns of data. Column A has the name of something and column D has either TRUE or FALSE.
I would like a macro wired to a button that creates a new text file in a given directory named after the content of Col A but only if Col D in that row is labled as "TRUE".
For example if I have the following.
ColA = Test ColD = TRUE
ColA = Test2 ColD = FALSE
ColA = Test3 ColD = TRUE
I will get 2 text files anmed Test.txt and Test3.txt.
I know I need a for each loop to look through the range of a1-d(whatever number) and then when D = True do a SaveAs I guess??
This is the code I have so far (yes I know it's very incomplete but this is as far as my logic got before hitting a wall).
Dim fileName As String
Dim filePath As String
Dim curCell As Object
Dim hideRange As Range
filePath = "C:\ExcelTest\"
hideRange = Range("D1:D1048576")
fileName = *Content of Cell A from this Row*
For Each Row In Range("A1:D1048576")
IF curCell.value In Range hideRange = "TRUE"
Then curCell.SaveAs fileName & ".txt, xlTextWindows
Any help or even pointing me in the right direction would be great. I searched around a bit for some examples and couldn't find anything that really matched what I wanted to do.
You are pretty close, but you are looping one hell of a lot of cells there.
Here is the code to loop the rows, this stops at the last populated cell in the column.
Sub LoopRows()
dim sht as worksheet
set sht = Thisworkbook.Sheets("Name of Worksheet")
'loop from row 1 to the last row containing data
For i = 1 To sht.Range("A:A").End(xlDown).Row
'check the value in column 4 for this row (i)
If sht.Cells(i, 4).Text = "TRUE" Then
CreateFile sht.Cells(i, 1).Value
End If
Next i
End Sub
For writing the file, to keep it simple it would reference Microsoft scripting runtime and do it as follows:
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\" & FileName & ".txt", True
End Sub
EDIT
I can't see why you aren't getting a file created, my tests work fine for me on a windows machine.
Can you please try the following code alone in a button and see if it opens a text file?
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\testfso.txt"
Shell "C:\WINDOWS\notepad.exe c:\temp\testfso.txt", vbMaximizedFocus
EDIT 2
Try this, and see if it opens the text file..
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
Dim fName as String
fName = "c:\temp\" & FileName & ".txt"
fso.CreateTextFile fName, True
Shell "C:\WINDOWS\notepad.exe " & fName, vbMaximizedFocus
End Sub
What you are looking for is something like this:
Sub test()
Dim filePath As String
filePath = "C:\ExcelTest\"
Dim xRow As Variant
For Each xRow In Range("A1:D100").Rows
If xRow(1, 4).Value = "TRUE" Then
Open filePath & xRow(1, 1) & ".txt" For Output As #1
Write #1, xRow(1, 2), xRow(1, 3)
Close #1
End If
Next
End Sub
While it works without errors, I would not use it as it is right now.
If you have any questions, just ask.
EDIT
I've run some tests and noticed windows prevents me to create files inside specific folders... pls try this as a new sub and run it:
Sub testForText()
Open Environ("AppData") & "\Testing.txt" For Output As #1
Write #1, "dada"
Close #1
Shell "notepad.exe " & Environ("AppData") & "\Testing.txt", vbNormalFocus
End Sub
Then tell me if notepad opens up with "Testing.txt"
In the code below I could wrote a code to display filenames from a folder. The problem is now that I should display them in the correct Row. For now they are displayed in random sequence and that is not the purpose.
In column "A" the filenames to search for are called with similar name format PBM12.T5.103.
The actual filename to find is called with similar name format 1_29_PBM_12_T5__103.
I have to find a solution to compare "only" the Fat marked letters and numbers like displayed here above, without . or _
As you will see PBM12T5103 is returning in both namestructures.
Please don't try fixed length counts because the filenames are dynamic and the amount of letters are variable. The comparison of the SUBSTITUTED length of column "A" ( PBM12T5103) is the key to comparison but I can not handle to establish this comparison.
When the filename in column "A" has been found, in column "C" the full filename of found file has to be displayed as the original format 1_29_PBM_12_T5__103
Maybe a solution can be found when extra columns can be made to establish the comparison?
In Excel I could approach a solution, but this will not work automized like it should do.
I made the LEN(count dynamic), but this is still no solution to display the full filenames in the required row...
Hopefully somebody can help me out ..
Option Explicit
Sub fileNames_in_folder()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim fldpath
Dim fld As Object, fil As Object, fso As Object, j As Long
fldpath = "C:\"
On Error Resume Next
Thisworkbook.Sheets("1").Activate
'start count row
j = 11
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
For Each fil In fld.Files
'here I have to add an IF statement in order to compare the filenames written in column "A" with files from folderPath C:\"
'When the correct files is found it should be displayed in column "C"
If
then
Cells(j, 34).Value = fso.GetBaseName(fil.path)
End If
'count behaviour
j = j + 1
Next
Columns("AH").AutoFit
End Sub
I will suggest you different way of getting file names. Instead of FileSystemObject let's use simple Dir function which allows to check the pattern of file name.
1) Files in my testing folder are as follows
2) I assumed that file pattern is as follows:
XXXY.Z.W
where:
XXX > 3 letters text
Y > any length number/text
Z > any length number/text
W > any length number/text
3) The code of subroutine is placed in 2013-06-01...xlsm file which you could see in the pic above (the same folder where your files are). Code is as follows (change where appropriate):
Sub solution()
Dim j As Long, LastRow As Long
Dim fldPath
'your path below
fldPath = ThisWorkbook.Path
ChDir fldPath
Dim arrPattern As Variant
Dim filName As String
For j = 1 To Range("A1").End(xlDown).Row
arrPattern = Split(Cells(j, "A"), ".")
'I suggest to use different way of checking _
pattern of file name. Pattern rules:
'*YYY*XX*Z*W*
filName = Dir("*" & Left(arrPattern(0), 3) & "*" & _
Mid(arrPattern(0), 4) & "*" & _
arrPattern(1) & "*" & _
arrPattern(2) & "*")
If Len(filName) > 0 Then
Cells(j, "B") = filName
Else
Cells(j, "B") = "not found"
End If
Next j
End Sub
4) results are presented in the picture below: