Path of separate workbook - vba

I wrote a macro as an AddIn so that it is available in any of the workbooks I open. This macro will automatically save an Excel file as a CSV file. When I open a new workbook (newwb.xlsx) and apply this AddIn, I want my code to automatically find the path where I saved this newwb.xlsx and save it in the same location.
I found online that Application.ActiveWorkbook.Path can be used to locate path itself and Application.ActiveWorkbook.FullName for the path with the workbook name. However, it only returns the path name of the AddIn file and not the path name of newwb.xlsx.
How do I get the file path of the new workbook file?
Here is my code:
'Declare the data type of the variables
Dim wks As Worksheet
Dim lastCol As Integer
Dim lastRow As Long
Dim iCol As Integer
Dim iRow As Long
Dim sFilename As String
Dim cellValue As String
Dim MyTextFile
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location of the csv file to a variable
sFilename = Application.ActiveWorkbook.FullName & "\newwb.csv"
'Within the current active worksheet, identify the last interested row and column of data
'Any values such as 'a', '1' or '%' are considered as values. Spaces (Spacebars) are not considered as values.
With wks
With .Cells(1, 1).CurrentRegion
lastCol = .Columns.Count
lastRow = .Rows.Count
End With
'Delete extra rows with blank spaces
For iRow = 1 To lastRow
For iCol = 1 To lastCol
cellValue = wks.Cells(iRow, iCol)
Next iCol
If Trim(cellValue) = "" Then
wks.Cells(iRow, iCol).EntireRow.Clear
wks.Cells(iRow, iCol).EntireColumn.Clear
End If
Next iRow
'Delete extra rows and columns with formats
.Cells(lastRow + 1, 1).Resize(Rows.Count - lastRow, 1).EntireRow.Clear
.Cells(1, lastCol + 1).Resize(1, Columns.Count - lastCol).EntireColumn.Clear
.UsedRange.Select
End With
'Save as .CSV file in the specific location stated earlier
'If there are errors in the code when Users presses 'No' for the conversion, set wks to nothing and end the process
On Error GoTo err_handler
wks.SaveAs Filename:=sFilename, FileFormat:=xlCSV
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
'Notify users that the .CSV file has been saved
MsgBox sFilename & " saved"
'Opens the CSV file in a specifc location in Notepad
MyTextFile = Shell("C:\Windows\notepad.exe ActiveWorkbook.Path & /S /K ""\newwb.csv""", vbNormalFocus)
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub
Edit:
Application.ActiveWorkbook.Path works at the line:
sFilename = Application.ActiveWorkbook.Path & "\newwb.csv"
but there is an error saying that the system cannot find the path in this line:
MyTextFile = Shell("C:\Windows\notepad.exe Application.ActiveWorkbook.Path & /S /K ""\newwb.csv""", vbNormalFocus)

ActiveWorknook.Fullname works correctly for me when used from an XLA.
Note that your code
sFilename = Application.ActiveWorkbook.FullName & "\newwb.csv"
does not use just the path to the active workbook but the path and name of the active workbook appended with \newwb.csv

I have found the way to run the code smoothly, in courtesy of How do you run a .exe with parameters using vba's shell()? . Hope this will help anyone in need, and I would like to appreciate my gratitude to those who have tried to help. Thanks!!
Final Code:
Option Explicit
Sub CreateCSV()
'Declare the data type of the variables
Dim wks As Worksheet
Dim lastCol As Integer
Dim lastRow As Long
Dim iCol As Integer
Dim iRow As Long
Dim sFilename As String
Dim cellValue As String
Dim MyTextFile
Dim strProgramName As String
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location of the csv file to a variable
sFilename = Application.ActiveWorkbook.Path & "\testing.csv"
'Within the current active worksheet, identify the last interested row and column of data
'Any values such as 'a', '1' or '%' are considered as values. Spaces (Spacebars) are not considered as values.
With wks
With .Cells(1, 1).CurrentRegion
lastCol = .Columns.Count
lastRow = .Rows.Count
End With
'Delete extra rows with blank spaces
For iRow = 1 To lastRow
For iCol = 1 To lastCol
cellValue = wks.Cells(iRow, iCol)
Next iCol
If Trim(cellValue) = "" Then
wks.Cells(iRow, iCol).EntireRow.Clear
wks.Cells(iRow, iCol).EntireColumn.Clear
End If
Next iRow
'Delete extra rows and columns with formats
.Cells(lastRow + 1, 1).Resize(Rows.Count - lastRow, 1).EntireRow.Clear
.Cells(1, lastCol + 1).Resize(1, Columns.Count - lastCol).EntireColumn.Clear
.UsedRange.Select
End With
'Save as .CSV file in the specific location stated earlier
'If there are errors in the code when Users presses 'No' for the conversion, set wks to nothing and end the process
On Error GoTo err_handler
wks.SaveAs Filename:=sFilename, FileFormat:=xlCSV
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
'Notify users that the .CSV file has been saved
MsgBox sFilename & " saved"
'Opens the CSV file in a specifc location in Notepad
strProgramName = "C:\Windows\notepad.exe"
MyTextFile = Shell("""" & strProgramName & """ """ & sFilename & """", vbNormalFocus)
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub

Related

Automatically update macro when changing filename

I have the following macro to filter specific data out of my directory with employee hours files and place it into my zmaster file. However, I need various master documents for various projects (EG. change name to: "project 300000"). When I change my master file name from zmaster to anything else, my macro cannot find the appropriate file, obviously.
Is there a way to change my macro in such a way that zmaster.xlsm is automatically replaced in my macro by the current file name?
Option Explicit
Sub CopyToMasterFile()
Dim MasterWB As Workbook
Dim MasterSht As Worksheet
Dim MasterWBShtLstRw As Long
Dim FolderPath As String
Dim TempFile
Dim CurrentWB As Workbook
Dim CurrentWBSht As Worksheet
Dim CurrentShtLstRw As Long
Dim CurrentShtRowRef As Long
Dim CopyRange As Range
Dim ProjectNumber As String
FolderPath = "C:\test\"
TempFile = Dir(FolderPath)
Dim WkBk As Workbook
Dim WkBkIsOpen As Boolean
'Check if zmaster is open already
For Each WkBk In Workbooks
If WkBk.Name = "zmaster.xlsm" Then WkBkIsOpen = True
Next WkBk
If WkBkIsOpen Then
Set MasterWB = Workbooks("zmaster.xlsm")
Set MasterSht = MasterWB.Sheets("Sheet1")
Else
Set MasterWB = Workbooks.Open(FolderPath & "zmaster.xlsm")
Set MasterSht = MasterWB.Sheets("Sheet1")
End If
ProjectNumber = MasterSht.Cells(1, 1).Value
Do While Len(TempFile) > 0
'Checking that the file is not the master and that it is a xlsx
If Not TempFile = "zmaster.xlsm" And InStr(1, TempFile, "xlsx", vbTextCompare) Then
Set CopyRange = Nothing
'Note this is the last used Row, next empty row will be this plus 1
With MasterSht
MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
With CurrentWBSht
CurrentShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For CurrentShtRowRef = 1 To CurrentShtLstRw
If CurrentWBSht.Cells(CurrentShtRowRef, "A").Value = ProjectNumber Then
'This is set to copy from Column A to Column L as per the question
If CopyRange Is Nothing Then
'If there is nothing in Copy range then union wont work
'so first row of the work sheet needs to set the initial copyrange
Set CopyRange = CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef)
Else
'Union is quicker to be able to copy from the sheet once
Set CopyRange = Union(CopyRange, _
CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef))
End If ' ending If CopyRange Is Nothing ....
End If ' ending If CurrentWBSht.Cells....
Next CurrentShtRowRef
CopyRange.Select
'add 1 to the master file last row to be the next open row
CopyRange.Copy MasterSht.Cells(MasterWBShtLstRw + 1, 1)
CurrentWB.Close savechanges:=False
End If 'ending If Not TempFile = "zmaster.xlsx" And ....
TempFile = Dir
Loop
ActiveSheet.Range("A1:L200").RemoveDuplicates Columns:=Array(1, 2, 4, 8, 9, 10, 11, 12), Header:=xlYes
End Sub
One way to escape from hard coded workbook names is to use ActiveWorkbook or ThisWorkbook objects - they both return instance of Workbook object.
ThisWorkbook
Returns a Workbook object that represents the workbook
where the current macro code is running. Read-only.
ActiveWorkbook
Returns a Workbook object that represents the workbook in the active
window (the window on top). Read-only. Returns Nothing if there are no
windows open or if either the Info window or the Clipboard window is
the active window.
Then you can get the name of the workbook with Name property of the returned Workbook object.
Another way could be if you pass such a data as parameter to your functions.
For example:
Sub CopyToMasterFile(wbName as String, sheetName as String)
In this variant if you call your Sub from another macro code, you can pass whatever you want to use - this ways you can escape the hard coded stuff in your functions.
This is also valid for the Worksheet objects - have a look on the ActiveSheet

VBA Script Stops Part Way Through File List

I have the following VBA code meant to loop through a given folder and compile all files of a certain type into one single worksheet.
Sub cons_data()
Dim Master As Workbook
Dim sourceBook As Workbook
Dim sourceData As Worksheet
Dim CurrentFileName As String
Dim myPath As String
Dim LastRow As Long
Dim lRow As Long
Dim i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'The folder containing the files to be recap'd
myPath = "path"
'Finds the name of the first file of type .xls in the current directory
CurrentFileName = Dir(myPath & "\*.txt*")
'Create a workbook for the recap report
Set Master = ThisWorkbook
For i = 1 To Master.Worksheets.Count
With Master.Worksheets(i)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If lRow > 1 Then .Rows("2:" & lRow).ClearContents
End With
Next i
Do
Workbooks.Open (myPath & "\" & CurrentFileName)
Set sourceBook = Workbooks(CurrentFileName)
For i = 1 To sourceBook.Worksheets.Count
Set sourceData = sourceBook.Worksheets(i)
With sourceData
LastRow = Master.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Rows("2:" & lRow).Copy Master.Worksheets("Sheet1").Rows(LastRow + 1)
End With
Next i
sourceBook.Close
'Calling DIR w/o argument finds the next .txt file within the current directory.
CurrentFileName = Dir()
Loop While CurrentFileName <> ""
MsgBox "Done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This script works fine on certain file types, but for some reason when running it on a list of text files with a standard format (some of which are duplicates) it stops and presents the most recent entry it was working on in a separate Excel sheet. Is there any obvious reason looking at the code that this might be happening?
You need to kill old processes and discharge resources memory by adding after :
Set sourceBook = nothing
After
sourceBook.close
Hope this can help

Copying worksheet data from multiple workbooks and pasting it into a master data file by worksheet

I am completely newbie to VBA however I was given a task to complete using VBA. How do I create a code which copies the data of multiple worksheets from different workbooks and pastes them into another workbook (master data file) by adding exactly the same number of separate worksheets to this master data file? That is, I would like to display all of those worksheets being copied over to separate worksheets in the master data file.
I have managed to pull off a code which copies the data over and pastes it into one single worksheet but I am struggling to get them copied over one by one to separate worksheets.
Your help is much appreciated.
Sub datatransfer()
Dim FolderPath, FilePath, Filename, targetfile As String
Dim wb1, wb2 As Workbook
Dim i, mycount As Long
targetfile = "Left the location out on purpose"
FolderPath = " Left the location out on purpose "
FilePath = FolderPath & "*.xls*"
Filename = Dir(FilePath)
Dim lastrow, lastcolumn As Long
Do While Filename < ""
mycount = mycount + 1
Filename = Dir()
Set wb1 = Workbooks.Open(FolderPath & Filename)
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy
Application.DisplayAlerts = False
Set wb2 = Workbooks.Open(targetfile)
Worksheets.Add Before:=Sheet1, Count:=2
For i = 1 To mycount
With Worksheets(i)
ActiveSheet.Paste Destination:=.Range(Cells(2, 2), Cells(2, lastcolumn))
End With
Next i
ActiveWorkbook.Close SaveChanges:=True
Filename = Dir
Loop
End Sub
See the code below. I made several notes where I modified the code a bit to ensure it works with hitches going forward.
Sub datatransfer()
'have to specify type for all variables, techinically it still works the way you did, but you are setting unncessary memory
Dim FolderPath As String, FilePath As String, Filename As String, targetfile As String
Dim wb1 As Workbook, wb2 As Workbook
targetfile = "Left the location out on purpose"
FolderPath = " Left the location out on purpose "
FilePath = FolderPath & "*.xls*"
Set wb2 = Workbooks.Open(targetfile) 'only need to open this once and leave open until execution is finished
Filename = Dir(FilePath)
Do While Filename <> "" ' need "<>" to say not equal to nothing
wb2.Worksheets.Add After:=wb2.Worksheets(wb2.Worksheets.Count) 'add new sheet to paste data in target book
Set wb1 = Workbooks.Open(FolderPath & Filename)
Dim lastrow As Long, lastcolumn As Long
With wb1.Worksheets(1) 'best to qualify all objects and work directly with them
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
'pretty sure you want to add this A1, since it's a new blank sheet
.Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy _
Destination:=wb2.Worksheets(wb2.Worksheets.Count).Range("A1")
End With
wb1.Close False 'assume no need to save changes to workbook you copied data from
Filename = Dir
Loop
wb2.Close True 'no close and save master file
End Sub

Import data from different Workbooks VBA

I have a code see below to import data from different workbooks inside one folder. I try it and it works perfectly however I was wondering if someone could help me to improve it.
I explain: "zmaster.xlms" workbook is the one where all data are past in sheet one. In this same workbook in sheet2 i have a table like this:
Where the column "Excel Column code" is where the data should be past (in the "zmaster.xlms") and "Form Cell Code" correspond to the cells which should be copy from every workbooks (which are in the same file in my desktop).
Question: How To say to the macro to look at the table and copy the cell K26 and past it in the columnA of the zmaster file and loop until the end of the table?
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
' Range("A1:D1").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
Thank you in advance for your help!
All you need to do is to loop through the cells in sheet 2 (zmaster.xlsm). Have a look at example code. Please, read comments.
[EDIT]
Code has been updated!
Option Explicit
'assuming that:
'- "Excel Column Code" is in column A
'- "Form Cell Code" is in column B
'in zmaster.xlsm!Sheet2
Sub UpdateData()
Dim sFile As String, sPath As String
Dim srcWbk As Workbook, dstWbk As Workbook
Dim srcWsh As Worksheet, dstWsh As Worksheet, infoWsh As Worksheet
Dim i As Long, j As Long, k As Long
On Error GoTo Err_UpdateData
Set dstWbk = ThisWorkbook
Set dstWsh = dstWbk.Worksheets("Sheet1")
Set infoWsh = dstWbk.Worksheets("Sheet2")
sPath = "C:\Desktop\New folder\"
sFile = Dir(sPath)
Do While Len(sFile) > 0
If sFile = "zmaster.xlsm" Then
GoTo SkipNext
End If
Set srcWbk = Workbooks.Open(sPath & sFile)
Set srcWsh = srcWbk.Worksheets(1)
i = 2
'loop through the information about copy-paste method
Do While infoWsh.Range("A" & i) <> ""
'get first empty row, use "Excel Column Code" to get column name
j = GetFirstEmpty(dstWsh, infoWsh.Range("A" & i))
'copy data from source sheet to the destination sheet
'use "Form Cell Code" to define destination cell
srcWsh.Range(infoWsh.Range("B" & i)).Copy dstWsh.Range(infoWsh.Range("A" & i) & j)
i = i + 1
Loop
srcwbk.Close SaveChanges:=False
SkipNext:
sFile = Dir
Loop
Exit_UpdateData:
On Error Resume Next
Set srcWsh = Nothing
Set dstWsh = Nothing
Set srcWbk = Nothing
Set dstWbk = Nothing
Exit Sub
Err_UpdateData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_UpdateData
End Sub
'returns first empty row in a destination sheet based on column name
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
At the moment you code
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
is simply copying columns A to D of the first row of data in the source worksheet to a new row in the destination worksheet.
I'm assuming that you still want to create a new single row, but that you want the table on sheet2 to define which cells are put into which column of the new row.
you need to write something like this (which is untested):
Sub YourCode()
Dim MyFile As String
Dim erow
Dim Filepath As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim rngMapping As Range
Dim DestinationRow As Long
Dim cell As Range
Filepath = "C:\Desktop\New folder\"
MyFile = Dir(Filepath)
Set wsDestination = ActiveWorkbook.Sheet1
' Named range "MappingTableFirstColumn" is defined as having the first column in the sheet2 table and all the rows of the table.
Set rngMapping = ActiveWorkbook.Names("MappingTable").RefersToRange
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Set wbSource = Workbooks.Open(Filepath & MyFile)
Set wsSource = wbSource.Sheets("Sheet1")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For Each cell In rngMapping
wsDestination.Range(cell.Value & DestinationRow) = wsSource.Range(cell.Offset(0, 1)).Value
Next cell
MyFile = Dir
Loop
ActiveWorkbook.Close
End Sub

Excel VBA: Combine multiple workbooks into one workbook

I have used the following script to copy multiple workbooks (sheets 1 only) into one master workbook. But, as multiple files are saved in the source folder each day, I now have hundreds of files in my source folder and would like to refine the folders that I copy to the master file.
I there a way to restrict the folders by using a date that appears in the file names. File path is ALWAYS the same format ...
5 alpha characters __ the date the file was saved (dateformat: ddmmyy) __ Julian Date
e.g.
NOCSR__060715__162959
SBITT__060715__153902
LVECI__030715__091316
Can I use the date in the file path and allow the user the input 'from' and 'to' dates? The master workbook would then only pull data from files that were saved within the date range.
Sub MergeFilesWithoutSpaces()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
ThisWB = ActiveWorkbook.Name
path = "K:\UKSW CS Bom Expections\CS_BOM_Corrections\Archive"
RowofCopySheet = 2
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
Set Dest = shtDest.Range("A" & shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1)
CopyRng.Copy
Dest.PasteSpecial xlPasteFormats
Dest.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'Clear Clipboard
Wkb.Close False
End If
Filename = Dir()
Loop
Thanks, SMORF
Im not sure you need to save the date in the file name. You can read the date created property of a file with this function...
Sub GetDateCreated()
Dim oFS As Object
Dim strFilename As String
'Put your filename here
strFilename = "c:\excel stuff\commandbar info.xls"
'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")
MsgBox strFilename & " was created on " & oFS.GetFile(strFilename).DateCreated
Set oFS = Nothing
End Sub
(pinched from here http://www.mrexcel.com/forum/excel-questions/73458-read-external-file-properties-date-created-using-visual-basic-applications.html)
Then you could write a function that takes a start date and end date and returns a list of filenames...