Hyperlink Columns = Excel Macro - excel

I have many pdfs and an excel sheet in one folder. The naming sequence is consistent.
Sheet will be named Apple.
Pdfs will be named Apple_1, Apple_2
I want an excel macro to work
Get the active sheet name.
Hyperlink the cells in G column.
When I click on text in cell 1, it should open Apple_1.pdf
When I click on cell 2, it should open Apple_2.pdf.
This should continue until text filled cells in that column.
I have a Word macro for the same, but I don't know how to make it work in excel. Below is the word macro.
Sub macro3()
Dim tbl As Table
Dim coll As Column
Dim path As String
Dim pdf As String
Dim path1 As String
pdfname = ActiveDocument.Name
pdfname = Left(pdfname, Len(pdfname) - 4)
pdfname = Replace(pdfname, " ", "_")
Set tbl = ActiveDocument.Tables(1)
Set coll = tbl.Columns(7)
Set colpdf = tbl.Columns(7)
i = 0
For Each c In coll.Cells
If (i <> 0 And InStr(c, ".pdf") > 0) Then
path1 = pdfname & "_" & i & ".pdf"
ActiveDocument.Hyperlinks.Add Anchor:=c.Range, Address:=path1
End If
i = i + 1
Next
End Sub

You are missing the directory path to the documents when setting path1. When you click the hyperlink to open its looking in a directory for "Apple1.pdf" which isn't a valid file path. You just need to add the directory path to the start of the path should look like "C:\MyPath\Apple1.pdf".
Your code:
pdfname = ActiveDocument.Name
pdfname = Left(pdfname, Len(pdfname) - 4)
pdfname = Replace(pdfname, " ", "_")
path1 = pdfname & "_" & i & ".pdf"
Solution1: Assuming the documents are in the same folder as activedocument.
Dim MyPath as string
MyPath = ActiveDocument.Path
path1 = MyPath & "\" & pdfname & "_" & i & ".pdf"
Solution2: Files are in another location you can add another string address.
Dim MyPath as string
MyPath = "C:\MyOtherLocation"
path1 = MyPath & "\" & pdfname & "_" & i & ".pdf"

Related

Change(some)Link(s) Name(s) of Active Workbook VBA

So, I renamed and moved some workbooks that are linked together and I need to update their xlExcelLinks on VBA, the thing is, I have a list of the references to update, but I can't figure out how to update only the ones I need and not every reference on the book.
The initial idea was to search for matching strings between a file name and the stored reference's path. Example data:
A2 Cell on Data.xlsx
Change to
I have this guide example code:
Sub Relink()
Dim previousFile, newFile, oldPath, newPath, Macro, altTab As String
'Macro stores the name of the file running the macro and altTab the name of the file to update
Dim ref as xlExcelLink 'Clearly not a type of data but I need something similar
Windows(Macro).activate
For I = 2 To 4
oldPath = Range("L"& I).Value
newPath = Range("M" & I).Value
previousFile = Range("N" & I).Value
newFile = Range("O" & I).Value
Windows(alTab).activate
'Somehow check for every reference avoiding itself
If ref.Address = oldPath & "\" & previousFile Then
ActiveWorkbook.ChangeLink Name:=oldPath & "\" & previousFile, _
NewName:=newPath & "\" & newFile, Type:=xlExcelLinks
End If
Next
End Sub
Note that on some files there could be only 1 update needed from 50ish references.
Try this code:
Sub UpdateLinks()
'Reference to your change list.
'ThisWorkbook is the file containing this code.
Dim ChangeList As Range
Set ChangeList = ThisWorkbook.Worksheets("Sheet2").Range("A2:D4")
'The workbook containing the links to change.
Dim wrkBk As Workbook
Set wrkBk = Workbooks("Test Timesheet.xlsx")
'If workbook isn't open use:
'Set wrkbk = workbooks.Open(<path to workbook>)
'Look at each link in the workbook.
'lnk must be Variant so it can be used in the For Each loop.
Dim lnk As Variant
For Each lnk In wrkBk.LinkSources
Dim OldPath As String
OldPath = Left(lnk, InStrRev(lnk, "\") - 1)
Dim OldFileName As String
OldFileName = Mid(lnk, InStrRev(lnk, "\") + 1, Len(lnk))
'Search for the existing path in first column of ChangeList.
Dim FoundLink As Range
Set FoundLink = ChangeList.Columns(1).Find(OldPath, , xlValues, xlWhole, xlByRows, xlNext)
'If it's not found, then continue to the next link.
'If it is found check that OldName also exists on that line, if it doesn't then continue searching.
If Not FoundLink Is Nothing Then
Dim firstAdd As String
firstAdd = FoundLink.Address
Do
If FoundLink.Offset(, 2) = OldFileName Then
'Found the link we're after so exit the loop.
Dim NewPath As String
NewPath = FoundLink.Offset(, 1)
Dim NewFileName As String
NewFileName = FoundLink.Offset(, 3)
Exit Do
Else
'Continue searching.
Set FoundLink = ChangeList.Columns(1).FindNext(FoundLink)
End If
Loop While firstAdd <> FoundLink.Address
'Make the change.
wrkBk.ChangeLink Name:=OldPath & Application.PathSeparator & OldFileName, _
NewName:=NewPath & Application.PathSeparator & NewFileName
End If
Next lnk
End Sub

Copying cells from multiple files in 1 folder based on partial file name

I made a post Copying cells from multiple files in one folder.
This answer was correct however I need to change it.
The code from this:
Sub Macro()
Dim StrFile As String, TargetWb As Workbook, ws As Worksheet, i As Long, StrFormula As String
Const strPath As String = "\\pco.X.com\Y\OPERATIONS\X\SharedDocuments\Regulatory\Z\X\" 'take care of the ending backslash
Set TargetWb = Workbooks("X.xlsm")
Set ws = TargetWb.Sheets("Macro")
i = 3
StrFile = Dir(strPath & "*.xls*") 'it returns all files having extensions as xls, xlsx, xlsm, xlsa, xlsb
Dim sheetName As String: sheetName = "S"
Do While Len(StrFile) > 0
StrFormula = "'" & strPath & "[" & StrFile & "]" & sheetName
ws.Range("B" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R24C3")
ws.Range("A" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R3C2")
i = i + 1
StrFile = Dir() 'needed to continue the iteration up to the last file
Loop
End Sub
In the folder where I pull the two data points from there are over 1000 workbooks. I only need the data from around 20/30 of these.
I was planning on getting all the data from this folder and then doing a quick play around to get to the stuff I need. The macro to pull from these 1000 docs is causing Excel to crash.
Is it possible to only pull the data from these files if part of the file name matches with a list of codes in the master sheet?
For example, in column B there are 20 codes listed "3333", "44444" , "562872" etc. and the only files I want are "ABCD 3333 BDBD", "AJKP 4444" and "hhhhh 562872 ha".
Using the function InStr() and an array could do the trick:
Sub Macro()
Dim StrFile As String, TargetWb As Workbook, ws As Worksheet, i As Long, StrFormula As String
Const strPath As String = "\\pco.X.com\Y\OPERATIONS\X\SharedDocuments\Regulatory\Z\X\" 'take care of the ending backslash
'this is the range where the filename codes are. Change as needed
Dim arr_files As Variant: arr_files = ThisWorkbook.Sheets("Master").Range("B2:B20")
Set TargetWb = Workbooks("X.xlsm")
Set ws = TargetWb.Sheets("Macro")
i = 3
StrFile = Dir(strPath & "*.xls*") 'it returns all files having extensions as xls, xlsx, xlsm, xlsa, xlsb
Dim sheetName As String: sheetName = "S"
Do While Len(StrFile) > 0
If Not file_to_process(StrFile, arr_files) Then GoTo skip_file
StrFormula = "'" & strPath & "[" & StrFile & "]" & sheetName
ws.Range("B" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R24C3")
ws.Range("A" & i).Value = Application.ExecuteExcel4Macro(StrFormula & "'!R3C2")
i = i + 1
skip_file:
StrFile = Dir() 'needed to continue the iteration up to the last file
Loop
End Sub
Private Function file_to_process(file_name As String, arr_files As Variant) As Boolean
Dim Key As Variant
For Each Key In arr_files
If InStr(1, file_name, Key, vbTextCompare) > 0 Then
file_to_process = True
Exit For
End If
Next Key
End Function
I've created a little function to check every filename for every code in the arr_files so if one filename has a code in the string, will check as true and get the data.

Loop to save worksheet in new workbook

I want to run through a specific sheet (from & to) save those ws as a new file in a folder, if the folder doesn't exist then create.
I'm able to do it to one sheet.
ActiveSheet.Next.Select
If Range("F3").Value = "" Then
Windows("Import OT.xlsm").Activate
Sheets("Cash").Select
Dim filename101 As String
Dim path101 As String
Application.DisplayAlerts = False
path101 = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
filename101 = Range("B1").Value & ".xlsx"
ActiveWorkbook.SaveAs path101 & Range("A2") & "\" & Range("A1") & " " & filename101,xlOpenXMLWorkbook
Application.DisplayAlerts = True
Else
Cells.Select
Range("F3").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Dim Path1 As String
Dim fpathname1 As String
Path1 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\"
fpathname1 = Path1 & Range("F3") & "\" & Range("F2") & " " & Range("B3") & ".xlsx"
path01 = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & Range("F3")
Dim path001 As String
Dim Folder As String
Folder = Dir(path01, vbDirectory)
If Folder = vbNullString Then
VBA.FileSystem.MkDir (path01)
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
Else
ActiveWorkbook.SaveAs filename:=fpathname1, FileFormat:=51
ActiveWorkbook.Close
Sheets("Cash").Select
End If
End If
End Sub
I want this as a loop is because I have a few tens of sheets. For it to work I think I need to write it specific time, but with loop I learned I don't need to do that.
Excel file sheet
https://onedrive.live.com/view.aspx?resid=AF6FF2618C09AC74!29027&ithint=file%2cxlsx&authkey=!AHcJjYCu8D0NTNY
According to your comment where you wrote the steps:
Read the comments
Try to run the code using F8 key and see where you need to change it.
As you're learning, please note to first write the steps in plain English Norsk and then develop your code.
See how I just followed your steps with readable code.
Code:
Public Sub GenerateCustomersFiles()
' 1) Active sheet (oppgjør 1-20)
Dim targetSheet As Worksheet
For Each targetSheet In ThisWorkbook.Sheets
' Check only sheets with string in name
If InStr(targetSheet.Name, "Oppgjør") > 0 Then
' 2) look if value in F3 is empty
If targetSheet.Range("F3").Value = vbNullString Then
' 3) if it is, do select "cash" sheet and save this file (its name and path are given above what it should be named)
Dim fileName As String
Dim filePath As String
Dim folderPath As String
folderPath = Environ("UserProfile") & "\Dropbox\A271\5 Oppgjor\" & 2020 & "\"
fileName = targetSheet.Range("B1").Value & ".xlsx"
filePath = folderPath & targetSheet.Range("A2") & "\" & targetSheet.Range("A1") & " " & fileName
ThisWorkbook.Worksheets("Cash").Select
ThisWorkbook.SaveAs filePath, xlOpenXMLWorkbook
Else
' 4) if it doesn't, do open selected sheet to a new workbook and save that in clients name folder (folder and path given above in code section)
folderPath = Environ("UserProfile") & "\Dropbox\A271\4 Lonnslipper\" & targetSheet.Range("F3")
fileName = targetSheet.Range("F2") & " " & targetSheet.Range("B3") & ".xlsx"
filePath = folderPath & "\" & fileName
' 5) check if clients folder exist or not for the file to be saved in.
' if folder doesnt exist,
' create new and save file there.
CreateFoldersInPath folderPath
' if folder exist just save the file there
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Add
targetSheet.Copy before:=targetWorkbook.Sheets(1)
targetWorkbook.SaveAs filePath, 51
targetWorkbook.Close
End If
End If
Next targetSheet
End Sub
' Credits: https://stackoverflow.com/a/31034201/1521579
Private Sub CreateFoldersInPath(ByVal targetFolderPath As String)
Dim strBuildPath As String
Dim varFolder As Variant
If Right(targetFolderPath, 1) = "\" Then targetFolderPath = Left(targetFolderPath, Len(targetFolderPath) - 1)
For Each varFolder In Split(targetFolderPath, "\")
If Len(strBuildPath) = 0 Then
strBuildPath = varFolder & "\"
Else
strBuildPath = strBuildPath & varFolder & "\"
End If
If Len(Dir(strBuildPath, vbDirectory)) = 0 Then MkDir strBuildPath
Next varFolder
'The full folder path has been created regardless of nested subdirectories
'Continue with your code here
End Sub
Let me know how it goes

Rename specific sheet from specific folder sub folders

I have several excel files in folder & want to rename only specific sheets of every file in the folder which contains
viz. GTLB, SALARY, GROC
Every file has a single sheet of above characters, other sheets have different names.
So, if sheet name contains above characters then change it to GROCERY.
thanks in advance
Try using this it will loop through the folder try finding files (excel files) and try looking for the strings in files that have been specified and if match found change the name.
Sub LoopThroughFiles()
'loops through all files in a folder
Dim MyObj As Object, MySource As Object, file As Variant
Dim wbk As Workbook
Dim path As String
Dim st As String
file = Dir("H:\TestCopy\testing\") 'file name
path = "H:\TestCopy\testing\" 'directory path
While (file <> "")
Set wbk = Workbooks.Open("H:\TestCopy\testing\" & file)
MsgBox "found " & file
' path = path & file 'path and filename
Call newloopTrhoughBooks
wbk.Save
wbk.Close
' Call loop_through_all_worksheets(path)
file = Dir
Wend
End Sub
Sub newloopTrhoughBooks()
Dim book As Workbook, sheet As Worksheet, text As String, text1 As String
Dim logic_string As String
Dim logic_string2 As String
Dim logic_string3 As String
logic_string = "GTLB"
logic_string2 = "SALARY"
logic_string3 = "GROC"
For Each book In Workbooks
text = text & "Workbook: " & book.Name & vbNewLine & "Worksheets: " & vbNewLine
For Each sheet In book.Worksheets
text = text & sheet.Name & vbNewLine
text1 = sheet.Name
If StrComp(logic_string, text1) = 1 Or StrComp(logic_string2, text1) = 1 Or StrComp(logic_string3, text1) = 1 Then 'compare file name
ActiveSheet.Name = text1
ActiveSheet.Name = "Change1"
End If
Next sheet
text = text & vbNewLine
Next book
MsgBox text
End Sub
Sub RenameSheets()
Dim MyFolder As String
Dim MyFile As String
Dim wbname As String
MyFolder = "E:\SSS\File Name"
MyFile = Dir(MyFolder & "\*.xls")
Application.ScreenUpdating = False
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
With ActiveWorkbook
wbname = "GROCERY"
'For giving filename to sheet1
'Left(.Name, InStr(.Name, ".") - 1)
For Each sheet In ActiveWorkbook.Sheets
If LCase(sheet.Name) Like "*salary*" Or LCase(sheet.Name) Like "*gtlb*" Or LCase(sheet.Name) Like "*groc*" Then
MsgBox "Found! " & sheet.Name
.Sheets(sheet.Name).Name = wbname
.Close savechanges:=True
End If
Next
'.Sheets(1).Name = wbname
'.Close savechanges:=True
End With
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

ExecuteExcel4Macro to get value from closed workbook

I found this bit of code and thought it might be good to use if I just need to pull one value from a closed sheet.
strInfoCell = "'" & strPath & "[" & strFile & "]Sheet1'!R3C3"
myvalue = ExecuteExcel4Macro(strInfoCell)
When I run this code I get a value for strinfocell of
'C:\Users\my.name\Desktop[QOS DGL stuff.xlsx]Sheet1'!R3C3
But when I run the code a dialogue pops up, showing desktop files with "QOS DGL suff" showing.
What's causing this, why is it not just pulling back the data as expected?
I know the path and file name are right, because if I copy them from the debug output and paste them in to start>>run then the correct sheet opens.
I know that Sheet1 (named: ACL), does have a value in cells(3,3)
It depends on how you use it. The open file dialog box is being showed to you because the "strPath" doesn't have a "" in the end ;)
Try this code.
Option Explicit
Sub Sample()
Dim wbPath As String, wbName As String
Dim wsName As String, cellRef As String
Dim Ret As String
'wbPath = "C:\Documents and Settings\Siddharth Rout\Desktop\"
wbPath = "C:\Users\my.name\Desktop\"
wbName = "QOS DGL stuff.xls"
wsName = "ACL"
cellRef = "C3"
Ret = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, -4150)
MsgBox ExecuteExcel4Macro(Ret)
End Sub
Similar application, but no hard coded paths as in the examples above. This function copies the value from another closed workbook, similar to the =INDIRECT() function, but not as sophisticated. This only returns the value...not a reference..so it cannot be used with further functions which require references (i.e.: VLOOKUP()). Paste this code into a new VBA module:
'Requires filename, sheetname as first argument and cell reference as second argument
'Usage: type in an excel cell -> =getvalue(A1,B1)
'Example of A1 -> C:\TEMP\[FILE1.XLS]SHEET1'
'Example of B1 -> B3
'This will fetch contents of cell (B3) located in (sheet1) of (c:\temp\file1.xls)
'Create a module and paste the code into the module (e.g. Module1, Module2)
Public xlapp As Object
Public Function getvalue(ByVal filename As String, ref As String) As Variant
' Retrieves a value from a closed workbook
Dim arg As String
Dim path As String
Dim file As String
filename = Trim(filename)
path = Mid(filename, 1, InStrRev(filename, "\"))
file = Mid(filename, InStr(1, filename, "[") + 1, InStr(1, filename, "]") - InStr(1, filename, "[") - 1)
If Dir(path & file) = "" Then
getvalue = "File Not Found"
Exit Function
End If
If xlapp Is Nothing Then
'Object must be created only once and not at each function call
Set xlapp = CreateObject("Excel.application")
End If
' Create the argument
arg = "'" & filename & "'!" & Range(ref).Range("A1").Address(, , xlR1C1)
'Execute an XLM macro
getvalue = xlapp.ExecuteExcel4Macro(arg)
End Function
Code above
strInfoCell = "'" & strPath & "[" & strFile & "]Sheet1'!R3C3"
myvalue = ExecuteExcel4Macro(strInfoCell)
Should read
strInfoCell = "'" & strPath & "[" & strFile & "]" & "Sheet1'!R3C3"
myvalue = ExecuteExcel4Macro(strInfoCell)
It is missing " & "
No need for a function
Cheers
Neil
Data = "'" & GetDirectory & "[" & GetFileName & "]" & Sheet & "'!" & Range(Address).Range("A1").Address(, , xlR1C1)
Address = "$C$3"
GetDirectory = "C:\Users\my.name\Desktop\"
GetFileName = "QOS DGL stuff.xlsx"
Sheet = "ACL"

Resources