Opening workbooks via hyperlink and then using Hyperlink name as workbook reference - vba

I'm trying to take the hyperlink workbook name and put it into my code.
Sub Workbook()
Dim vbaname as string
Dim WBMaster As Workbook, WBSource As Workbook
Dim WSMaster As Worksheet, WSSource As Worksheet
Range("b7").Hyperlinks(1).Follow
'returns the hyperlink text "Vba Source test"
VbaName = """" & Range("B7").Text & """"
Set WBSource = Workbooks(VbaName)
I get a subscript out of range bug. Is there another way to do this. I just want to be able to put the hyperlink text into that bracket.

If you Debug.Print your VbaName it actually holds the value of B7 but the active window ( the followed one from hyperlink ). If you want to get the name of the workbook from the hyperlink, youre working in, then use this code
Sub GetWorkbookName()
MsgBox "the name of the workbook in the hyperlink is: " & vbCrLf & _
getWorkbookName(Range("B7").Text)
End Sub
Private Function getWorkbookName(hyperLink As String) As String
Dim i&
For i = 1 To Len(hyperLink)
If StrComp(Left(Right(hyperLink, i), 1), "\", vbTextCompare) = 0 Then
getWorkbookName = Right(hyperLink, i - 1)
Exit For
End If
Next i
End Function
On the other hand, I think you are trying to open the workbook from the hyperlink and assign a reference to it. The way you go about it it's not the right approach. I think you may want to consider doing it this way:
Sub Workbook()
Dim wbFromHyperLink As String
Dim WBSource As Workbook
MsgBox "the name of the workbook in the hyperlink is: " & vbCrLf & _
getWorkbookName(Range("B7").Text)
wbFromHyperLink = getWorkbookName(Range("B7").Text)
'Range("b7").Hyperlinks(1).Follow
Set WBSource = Workbooks.Open(Range("B7").Text)
' do not forget to close and free the object
' WBSource.Saved = True
' WBSource.Close
' Set WBSource = Nothing
End Sub
Private Function getWorkbookName(hyperLink As String) As String
Dim i&
For i = 1 To Len(hyperLink)
If StrComp(Left(Right(hyperLink, i), 1), "\", vbTextCompare) = 0 Then
getWorkbookName = Right(hyperLink, i - 1)
Exit For
End If
Next i
End Function

Related

Excel 2013 cannot find and open the file in ThisWorkbook directory

The following issue occured to me. I use MS Excel 2013.
With the macro below I tried to find those accounts (which meets the criteria "In scope", e.g. account 12345678), to copy them, to search in the same folder (where ThisWorkbook is), to find another excel file which has as name the number of account (e.g. "12345678.xlsx") and to open it.
After the proposed corrections below, my macro finds and opens the desired file. But now the problem is that no actions can be performed on it: copy, paste, etc.
Could you please help on this?
Sub FileFinder()
'Excel variables:
Dim RngS As Excel.Range
Dim wbResults As Workbook
'Go to the column with specific text
Worksheets("Accounts source data").Activate
X = 3
Y = 25
While Not IsEmpty(Sheets("Accounts source data").Cells(X, Y))
Sheets("Accounts source data").Cells(X, Y).Select
If ActiveCell = "In scope" Then
Sheets("Accounts source data").Cells(X, Y - 22).Select
'Copy the account in scope
Set RngS = Selection
Selection.Copy
'Search, in same directory where the file is located, the file with that account (file comes with account number as name)
sDir = Dir$(ThisWorkbook.Path & "\" & RngS & ".xlsx", vbNormal)
Set oWB = Workbooks.Open(ThisWorkbook.Path & "\" & sDir)
'Here is where my error occurs
'[Run-time error 5: Invalid procedure call or argument]
Sheet2.Cells("B27:B30").Copy
oWB.Close
End If
X = X + 1
Wend
End Sub
Try the code below, I have my explanation and questions for you in the code (as commnets):
Option Explicit
Sub FileFinder()
' Excel variables:
Dim wbResults As Workbook
Dim oWB As Workbook
Dim Sht As Worksheet
Dim RngS As Range
Dim sDir As String
Dim LastRow As Long
Dim i As Long, Col As Long
Col = 25
' set ThisWorkbook object
Set wbResults = ThisWorkbook
' set the worksheet object
Set Sht = Worksheets("Accounts source data")
With Sht
' find last row with data in Column "Y" (Col = 25)
LastRow = .Cells(.Rows.Count, 25).End(xlUp).Row
For i = 3 To LastRow
If .Cells(i, Col) = "In scope" Then
' Set the range directly, no need to use `Select` and `Selection`
Set RngS = .Cells(i, Col).Offset(, -22)
' Search, in same directory where the file is located, the file with that account (file comes with account number as name)
sDir = Dir$(ThisWorkbook.Path & "\" & RngS.Value & ".xlsx", vbNormal)
Set oWB = Workbooks.Open(ThisWorkbook.Path & "\" & sDir)
oWB.Worksheets("Report").Range("B27:B30").Copy
' *** Paste in ThisWorkbook, in my exmaple "Sheet2" <-- modify to your needs
wbResults.Worksheets("Sheet2").Range("C1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
oWB.Close SaveChanges:=False
' sDir = Dir$
' clear objects
Set RngS = Nothing
Set oWB = Nothing
End If
Next i
End With
End Sub

Save Worksheets to new Workbook By Checkbox [Excel Macro/VBA]

So my main goal is to save sheets (depending on if they are selected by a checkbox) to a new workbook.
Here is my code:
Sub saveSheetWorkbook()
Dim exampleName As Variant
Dim exampleSavePath As String
Dim exampleSheet As Variant
exampleName = InputBox("Who will this be sent to?")
exampleSavePath = ActiveWorkbook.Path & "\" & exampleName
If Worksheets("Example Worksheet 1").Range("E29") = True Then
exampleSheet = "Example Worksheet 2"
End If
Sheets(Array("Example Worksheet 1"), exampleSheet).Copy
ActiveWorkbook.SaveAs Filename:=exampleSavePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
For example, I want to always save Example Worksheet 1, but only save Example Worksheet 2 if the checkbox is ticked. The cell E29 in Example Worksheet 1 is the linked cell for the checkbox.
So this macro works when the checkbox is ticked, but when the checkbox is unticked, I get an error.
I have set it up so that the sheet array either contains the name or nothing. but when containing nothing, that gives me the error.
Any help would be great.
Edit: I need this for 6 different checkboxes/sheets.
you have one parenthesis too much
then
Sub saveSheetWorkbook()
Dim exampleName As Variant
Dim exampleSavePath As String
Dim sheetsArray As Variant
exampleName = InputBox("Who will this be sent to?")
exampleSavePath = ActiveWorkbook.Path & "\" & exampleName
If Worksheets("Example Worksheet 1").Range("E29") Then
sheetsArray = Array("Example Worksheet 1", "Example Worksheet 2")
Else
sheetsArray = Array("Example Worksheet 1")
End If
Sheets(sheetsArray).Copy
ActiveWorkbook.SaveAs Filename:=exampleSavePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub
You can use my example workbook to do this with form:
https://drive.google.com/open?id=0BzFv0oeets6ubHg2bk96SHotdkU
To create this by yourself, here is instructions:
Press ALT+F11 in order to open VBA window;
Create userform with name "Userform1"
Put listbox to form and change its name to "lstSheet"
Change its properties like shown below:
ListStyle: 1-fmListStyleOPtion;
MultiSelect: 1-fmMultiSelectMulti;
Userform code:
Option Explicit
Dim NewName As String
Dim ws As Worksheet
Dim NumSheets As Integer
Private Sub CommandButton1_Click()
Dim Count As Integer, i As Integer, j As Integer
Count = 0
For i = 0 To lstSheet.ListCount - 1
'check if the row is selected and add to count
If lstSheet.Selected(i) Then Count = Count + 1
Next i
For i = 0 To lstSheet.ListCount - 1
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Select True
Next i
For i = 0 To lstSheet.ListCount - 1
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Select False
If lstSheet.Selected(i) Then Sheets(lstSheet.List(i)).Activate
Next i
Unload Me
ActiveWindow.SelectedSheets.Copy
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Private Sub lstSheet_Click()
End Sub
Private Sub UserForm_Initialize()
Dim Sh As Variant
'for each loop the add visible sheets
For Each Sh In ActiveWorkbook.Sheets
'only visible sheetand exclude login sheet
If Sh.Visible = True Then
'add sheets to the listbox
Me.lstSheet.AddItem Sh.Name
End If
Next Sh
End Sub
Create Module and put this code there:
Sub showForm()
Userform1.Show
End Sub

Filename is empty when trying to open file

I try to merge workbooks from a folder in a new workbooks. The VBA code reads the excel file from folder, add every file name to a list box and then, after pressing the button "Start", add very file to the workbook. That is the idea.
The code is as folows:
When opening the file the userform is shown:
Private Sub Workbook_Open()
UserForm1.Show
End Sub
When activating userform, the list box is populated:
Private Sub UserForm_Activate()
Const strFolder As String = "C:\Users\user\Desktop\tmp\"
Const strPattern As String = "*.xls"
Dim strFile As String
Dim collection As New collection
Dim i As Integer
Dim isMerger As Integer
Dim lngth As Integer
strFile = Dir(strFolder & strPattern, vbNormal)
If (StrComp(strFile, "FileMerger.xls") <> 0) Then
If (Len(strFile) <> 0) Then
col.Add (strFolder & strFile)
Do While Len(strFile) > 0
strFile = Dir
If (StrComp(strFile, "FileMerger.xls") <> 0) Then
If (Len(strFile) <> 0) Then
col.Add (strFolder & strFile)
End If
End If
Loop
End If
End If
Vars.xlsFiles = ColToArray(collection)
For i = 1 To UBound(Vars.xlsFiles)
lstFiles.AddItem (Vars.xlsFiles(i))
Next i
End Sub
At this moment listbox and array Vars.xlsFiles are populated; they are OK.
Click on Start button in the userform:
Private Sub cmdStart_Click()
Dim fileName As String
Dim sheet As Worksheet
Dim i As Integer
Dim ub As Integer
ub = UBound(Vars.xlsFiles)
For i = 1 To ub
Workbooks.Open fileName:=Vars.xlsFiles(i), ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
Next i
End Sub
In the folder are 3 files. Their name are in the listbox. But when the first is to be closed I received an error message and after debugging it says that fileName ="" (line Workbooks(fileName).Close).
whatever I try I got the same error, i.e. fileName = "".
What to do ?
Your never set the variable fileName, so it's still the default value "". Maybe you got confused by the fileName:=Vars.xlsFiles(i) of the Workbooks.Open method. That just sets the option FileName of that method. Use some unique name to avoid confusion and set it to Vars.xlsFiles(i) or use
Workbooks(Vars.xlsFiles(i)).close
FileName:= is a named parameter of the Workbooks.Open method. It does not set the value of the cmdStart_Click's fileName variable.
Private Sub cmdStart_Click()
Dim fileName As String
Dim sheet As Worksheet
Dim i As Integer
Dim ub As Integer
ub = UBound(Vars.xlsFiles)
For i = 1 To ub
fileName = Vars.xlsFiles(i)
Workbooks.Open FileName:=fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
Next i
End Sub

VBA: Open file from cell then move to next cell

I currently have a list of files with the file path (C:/something.xlxs) in column B of a sheet. I want to write a Macro to read the value from the cell, open the file, and then move on to the next cell and open that file, etc.
I currently have this:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
For i = 1 To 5
If Not IsEmpty(Cells(i, 2)) Then
sFullName = Cells(i, 2).Value
Workbooks.Open fileName:=Cells(i, 2).Value, UpdateLinks:=0
End If
Next i
End Sub
It is only opening the first file from the list and then stopping. It is probably a small error but I am having trouble spotting it.
Thanks
I would do it this way:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
Dim wsh As Worksheet
On Error GoTo Err_openFiles
Set wsh = ThisWorkbook.Worksheets("Sheet1")
i = 1
Do While wsh.Range("B" & i)<>""
sFullName = wsh.Range("B" & i)
Application.Workbooks.Open sFullName, UpdateLinks:=False
i = i+1
Loop
Exit_openFiles:
On Error Resume Next
Set wsh = Nothing
Exit Sub
Err_openFiles:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_openFiles
End Sub
Above code works in context and provides a way to handle errors.
Try
Dim wb As Excel.Workbook
Set wb = Workbooks.Open(Filename:=sFullName)

Clear copy of current file from data

There is workflow to fill in a sheet and mail it when you're done. The method to mail will send the current sheet as attachment, but it should directly create a new copy of the sheet where all your data is removed from.
I can clear the current sheet, but that's wrong, as I need to clear the new sheet. I have read about running macros on other workbooks, but it fails to run the macro. What's the best solution?
Sub SendData_Click()
If MsgBox("Sure to send?", vbYesNo, "Confirm") = vbYes Then
' Save current sheet
ActiveWorkbook.Save
' Send the current file
Mail_ActiveSheet
' Mark this sheet as sent
Worksheets("Data").Range("B6").Value = True
' Create a new emptied version
Create_New_Copy
MsgBox "Your data is sent"
End If
End Sub
Sub Create_New_Copy()
Dim Wb As Workbook
Dim NewFileName As String
Dim FileExtStr As String
Dim FilePath As String
Set Wb = ActiveWorkbook
NewFileName = "FileNameHere " & Format(DateAdd("d", 1, Now), "yyyy-mm-dd")
FileExtStr = "." & LCase(Right(Wb.Name, Len(Wb.Name) - InStrRev(Wb.Name, ".", , 1)))
FilePath = ActiveWorkbook.Path & "\" & NewFileName & FileExtStr
' # This is the problem, how to clear only the new file??
' Clear_Sheet_Invoices
' Save this sheet as the new file
Wb.SaveCopyAs FilePath
End Sub
Sub Clear_Sheet_Invoices()
Dim Ws As Worksheet
Set Ws = Worksheets("MyDataSheet")
' Remove all contents
Ws.Range("B2:F999").ClearContents
' Mark the "sent" flag for the new sheet to False
Worksheets("Data").Range("B6").Value = False
End Sub
As you might note, I am using ActiveWorkbook.SaveCopyAs to create a copy, and I have a Sub Clear_Sheet_Invoices which can clear all required data. How to run this sub on the new file?
I have thought to copy the MyDataSheet to a new sheet, clear the data sheet, save the new file and copy the sheet back. On opening a file, I check if a copy of the sheet is present and I will remove the sheet. Yeah, damn ugly, there should be a better way right? ;)
You can change the definition of Clear_Sheet_Invoices() in that way that it requires a parameter of Workbook type and it would clear worksheet "MyDataSheet" in this workbook.
Then you can invoke this sub and pass the newly created workbook as a parameter.
Below is the code you need to change to implement it:
Sub Clear_Sheet_Invoices(Wb As Workbook)
Dim Ws As Worksheet
Set Ws = Wb.Worksheets("MyDataSheet")
' Remove all contents
Ws.Range("B2:F999").ClearContents
' Mark the "sent" flag for the new sheet to False
Wb.Worksheets("Data").Range("B6").Value = False
End Sub
Sub Create_New_Copy()
Dim Wb As Workbook
Dim NewWb As Workbook
Dim NewFileName As String
Dim FileExtStr As String
Dim FilePath As String
Set Wb = ActiveWorkbook
NewFileName = "FileNameHere " & Format(DateAdd("d", 1, Now), "yyyy-mm-dd")
FileExtStr = "." & LCase(Right(Wb.Name, Len(Wb.Name) - InStrRev(Wb.Name, ".", , 1)))
FilePath = ActiveWorkbook.Path & "\" & NewFileName & FileExtStr
' Save this sheet as the new file
Wb.SaveCopyAs FilePath
Set NewWb = Excel.Workbooks.Open(FilePath)
' # This is the problem, how to clear only the new file??
Call Clear_Sheet_Invoices(NewWb)
Call NewWb.Close(True)
End Sub
Method SendData_Click doesn't require any changes.