All - I am looking to write a loop where I can change the filename and folder location depending on the value that it runs in the loop. For example, if I am running the macro from cells G2:G7, when the process moves from G2 to G3, I want the filename and folder location to change according to some reference table (look image for details). Effectively, I want the filename and foldername to be lookups to the Fund Types.
Public Sub Get_File()
Dim sFiletype As String
Dim sFilename As String 'Save the file as this name, if "" then default
Dim sFolder As String 'Save to this folder, if "" then default
Dim bReplace As Boolean 'To replace the existing file or not
Dim sURL As String 'The URL to the location to extract information
Dim cell, Rng As Range
Dim sheet As Worksheet
'Initialize variables
Set Rng = Range("I2:I10")
Set sheet = ActiveWorkbook.Sheets("Macro_Button")
For Each cell In Rng
If cell <> "" Then
sFiletype = cell.Value
sFilename = sFiletype & "_" & Format(Date, "mmddyyyy")
sFolder = Application.WorksheetFunction.VLookup(sFiletype, sheet.Range("G2:J10"), 4, False)
bReplace = True
sURL = "www.preqin.com"
'Download using the desired approach, XMLHTTP / IE
Call Download_Use_IE(sURL, sFilename, sFolder, bReplace)
Else
Exit Sub
End If
Next
End Sub
Thanks everyone for your input!
http://i.stack.imgur.com/M6GSs.png
Therein lies the limitation of VLookUp where matches must align to the leftmost column and only searches to the right. As advised in the popular web search, consider an Index/Match replacement which compares column to column and returns value on matched row (in any direction):
sFolder = Application.WorksheetFunction.Index(sheet.Range("G2:J10"), _
Application.WorksheetFunction.Match(sFiletype, sheet.Range("I2:I10"), 0), 4)
If needing to use VLookUp(), you would need to decrease your lookup range:
sFolder = Application.WorksheetFunction.VLookup(sFiletype, sheet.Range("I2:J10"), 2, False)
Instead of vlookup, I suggest placing the exact folders into the code given that you only have 8 choices. This makes it readily obvious for debugging. You can do this via a case statement. See here for more information.
Select Case sFilename
Case abc
sFolder = "C:\One\"
Case def
sFolder = "C:\Two\"
Case ghi
sFolder = "C:\Three\"
'so forth for 8 cases...
End Select
Related
I have a xlsm that amonst others runs through all .xslx files in a directory, runs a sub, saves them. (Thank you Tabias)
inside this sub I am now trying to add something that would add the last column from a third file.
My first problem here is how to define the sourcefile. We need to take data from the exact file, with a similar name. So MC.xslx ahs to copy from MC12february.xlsx and KA.xlsx has to import from KAwhateverdate.xlsx
Set wbA = Workbooks.Open("C:\files" & "\" & ActiveWorkbook.Name & "*.xlsx")
unfortunately, active.workbook.name includes the extention, so OR you guys can tell me a solution OR i have to save the files date+name first and change it into wbA = Workbooks.Open("C:\files" & "\*" & ActiveWorkbook.Name) right?
The same goes for the sheet. Those wil, depending on the file, be called MC, KA,KC,...
Next since i only want to copy the last column of the file into the last column of the other file I'm quite confused. I found this code and thought it was the most understandable.
Sub import()
Dim Range_to_Copy As Range
Dim Range_Destination As Range
Dim Sheet_Data As Worksheet 'sheet from where we pull the data
Dim Sheet_Destination As Worksheet ' destination
Dim workbook_data As Workbook
Dim workbook_destination As Workbook
Set workbook_data = "N:\blah\deposit" & "\*" & ActiveWorkbook.Name
Set workbook_detination = ActiveWorkbook
Set Sheet_Data = ThisWorkbook.Sheets("Sheet1") 'help, how do i do this?
Set Sheet_Destination = ThisWorkbook.Sheets("Sheet1") ' and this?
Set Range_to_Copy = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
Set Range_Destination = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
Range_to_Copy.Copy Range_Destination 'this copies from range A to B (basically A.copy B), but i changed variable names to make it easier...
'you can simplify without variables like this:
'Sheets("Sheet1").Range("D1").Copy Sheets("Summary).Range("A1") <===== does the same as the above coding
None of the more simpler solutions seemed fit either. example
As you see I'm completely stuck at how to define the last column and the name of the sheet. This code is to uncomplete for me to check by doing. Can someone put me on the right path? thank you.
As a supplement, I'd suggest creating a simeple, re-usable file open functions where you can provide a filename as a String that you'd like to search for. The function will loop through a directory (as Batman suggested) and, optionally, pull the most recent version (using date modified) of that file. Below is a set of functions that I use frequently. There is a subfolder parameter `subF' that will allow you to search within subfolder(s) relative to the current file location.
'FUNCTION opnWB
'--Opens a workbook based on filename parameter
'----WILDCARDS before and after the filename are used to allow for filename flexibility
'----Subfolder is an OPTIONAL PARAMETER used if the location of the file is located in a subfolder
Public Function opnWB(ByVal flNM As String, Optional ByVal subF As String = "") As Workbook
If subF <> "" Then subF = "\" & subF
Dim pthWB As String
pthWB = "\*" & flNM & "*" 'wildcard characters before and after filename
pthWB = filePull(subF, pthWB)
Set opnWB = Workbooks.Open(ActiveWorkbook.path & subF & "\" & pthWB, UpdateLinks:=0)
End Function
'FUNCTION filePull
'--Cycles through folder for files that match the filename parameter (with WILDCARDS)
'--If there is more than one file that matches the filename criteria (with WILDCARDS),
'----the file "Date Modified" attribute is used and the most recent file is "selected"
Private Function filePull(ByVal subF As String, ByVal path As String) As String
Dim lDate, temp As Date
Dim rtrnFl, curFile As String
Filename = Dir(ActiveWorkbook.path & subF & path)
Do While Filename <> ""
curFile = Filename
curFile = ActiveWorkbook.path & subF & "\" & Filename
If lDate = 0 Then
rtrnFl = Filename
lDate = GetModDate(curFile)
Else
temp = GetModDate(curFile)
End If
If temp > lDate Then
rtrnFl = Filename
lDate = temp
End If
Filename = Dir()
Loop
filePull = rtrnFl
End Function
'FUNCTION GetModDate
'--Returns the date a file was last modified
Public Function GetModDate(ByVal filePath As String) As Date
GetModDate = CreateObject("Scripting.FileSystemObject").GetFile(filePath).DateLastModified
End Function
You could tweak this method where the filename would have to start file the String you pass in by simply removing the wildcard character before flNM. To use, you would simply call the opnWB function, passing in "MC" or whatever general file name you'd like to open:
Dim wbTarMC as Workbook
Set wbMC = opnWB("MC", "Source Files") 'this would open up MC.xlsx file within the subfolder "Source Files" (relative to current file location)
Hope this helps.
As we know, we use Find() method to find whether a string or any Microsoft Excel data type exists in an excel.
(Usually we do it on set of data)
I want to know if any such method available when we loop through folder(of files) using Dir function.
Situation:
I have an excel - 'FileNames.xlsx' in which 'Sheet1' has names of files having extensions .pdf/.jpg/.jpeg/.xls/.xlsx/.png./.txt/.docx/ .rtf in column A.
I have a folder named 'Folder' which has most(or all) of the files from 'FileNames.xlsx'.
I have to check whether all the file-names mentioned in the 'FileNames.xlsx' exist in 'Folder'.
For this I have written the below VBScript(.vbs):
strMessage =Inputbox("Enter No. of Files in Folder","Input Required")
set xlinput = createobject("excel.application")
set wb123 =xlinput.workbooks.Open("E:\FileNames.xlsx")
set sh1 =wb123.worksheets("Sheet1")
For i = 2 to strMessage +1
namei = sh1.cells(i,1).value
yesi = "E:\Folder"+ namei +
If namei <> yesi Then
sh1.cells(i,1).Interior.Color = vbRed
Else
End If
Next
msgbox "Success"
xlinput.quit
As I wasn't able to get the required Output I tried it recording a small Excel VBA Macro. (Changed FileNames.xlsx to FileNames.xlsm)
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2A:" & lastRow)
MyFile = Dir(MyFolder & "\*.xlsx")
'Here I actually need to pass all file extensions to Dir
Do While MyFile <> ""
If filename = MyFile Then
'Do Nothing
Else
filename.Interior.Color = vbRed
MyFile = Dir
Next
End Sub
The above is a failed attempt.
I thought of trying it with method similar to Find()
Sub LoopThroughFiles()
Dim lastRow As Long
'Dim LastFile As Long
'Is there need of it (LastFile variable)? I kept this variable
'to save (prior known) count of files in folder.
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
'LastFile = 'Pass count of Files in folder to this variable.
Dim fileName As Range
For Each fileName In Worksheets("Sheet1").Range("A2:A" & lastRow)
Dim rngFnder As Range
On Error Resume Next
'Error at below line.
Set rngFnder = Dir("E:\Folder\").Find(filename)
'This line gives me error 'Invalid Qualifier'
'I am trying to use method similar to Find()
If rngFnder Is Nothing Then
filename.Interior.Color = vbRed
End If
Next
End Sub
But, I couldn't achieve the result. Can anyone tell me is there any such function available to 'Find' whether all filenames in an excel exist in a folder after looping through folder using Dir?
As per my knowledge, Dir function works with only one file extension at a time.
Is it possible to use Dir function for multiple file extensions at a time?
Expected Output:
Assume I have 8 filenames in 'FileNames(.xlsx/.xlsm)'. Out of which Arabella.pdf and Clover.png are not found in 'Folder', Then I want to color cells for these filenames in red background in excel as in below image.
Sub LoopThroughFiles()
Dim lastRow As Long
lastRow = Sheets("Sheet1").UsedRange.Rows.Count
Dim MyFolder As String
Dim filename As Range
Dim MyFile As String
MyFolder = "E:\Folder"
For Each filename In Worksheets("Sheet1").Range("A2:A" & lastRow)
MyFile = MyFolder & "\" & filename
If Not FileExists(MyFile) Then
filename.Interior.Color = vbRed
End If
Next
End Sub
Public Function FileExists(strFullpathName As String) As Boolean
If Dir(strFullpathName) <> "" Then
FileExists = True
Else
FileExists = False
End If
End Function
You can output a list of the files that are contained in the folder. I found a really helpful tutorial on that here: http://software-solutions-online.com/2014/03/05/list-files-and-folders-in-a-directory/#Jump1
If you then loop through both the original and the output lists and look for a match. Easiest is to first colour them all red, and un-colour the matches. Else you would need an additional if-statement that states: When you reach the last element in the original list, and no match has been found, then colour red.
Edit: For continuity's sake I copied the code bits of the link I mentioned above:
Getting all file names form within 1 folder:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("D:StuffFreelancesWebsiteBlogArraysPics")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
Cells(i + 1, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
my Access database exports a report in xls, that needs to be further reworked (some manual adjustments of columns etc. + vlookuping some comments from report from previous day).
Here is the part of the code I created so far:
Option Compare Database
Function Adjustment()
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY!C7:C12,4,0)"
End function
Problem: I am being prompted every every time to select the file, when formula is being filled in I2 and J2, so how can I disable this and keep Access to reference strFile only once?
Question: So far, every first sheet in the refrenced workbook is called SheeyXY, but what if I would like to reference also a different Sheets (let`s say always the first sheet in the workbook no matter what its name is).
Maybe you can try this ..
Option Compare Database
Function Adjustment(SheetName as String) '---> add parameter such as "SheetXY"
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFolder As String
Dim varItem As Variant
Static strFile As String
If strFile = "" Then
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
Endif
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,4,0)"
End function
Have you tried taking out the .FormularR1C1 from those lines?
Also, I'm not sure exactly what you're trying to do with the sheet names, but you could probably hack something together from this?
Debug.Print Worksheets(1).Name
or
For Each ws In Worksheets
Debug.Print ws.Name
Next
UPDATE:
Try this, and report back?
With xl.Worksheets(1)
.Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,3,0)"
.Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,4,0)"
End With
So with the extra clarification of which range, and without the extra apostrophe
Say I have the following path and file name:
P:\...\Annual and Quarterly Budget Data\ECMQA 2012Q1.xls
I want to write an if then statement that does the following (not sure if my statement is set up properly):
If InStr(1, "P:\...\Annual and Quarterly Budget Data\ECMQA 2012Q1.xls", "QA", vbTextCompare) > 0 Then
BD.Sheets("Sheet1").Range("C2").value = "2012Q1"
End If
Instead of just inputting "2012Q1", I want it to automatically read this from the file. The thing is I am actually looping through 12 or so files and there's two types, "ECMQA 2012Q1.xls" (or ECMQB 2012Q2.xls and so on) AND "ECM Annual Budget 2012.xlsx"
If my file is the annual one (If file contains "Annual"), then I want:
BD.Sheets("Sheet1").Range("C2").value = "2012"
And i want it to read this from the actual file, same as the other one...not me putting in "2012"
Is there a way to do this?
Any help will be appreciated!
EDIT:
Here is the loop:
Dim wb As Workbook, sFile As String, sPath As String
Dim itm As Variant
Dim strFileNames As String
sPath = "C:\Actuary\Cash Flow Forecast\Annual and Quarterly Budget Data\"
''Retrieve the current files in directory
sFile = Dir(sPath)
Do While sFile <> ""
strFileNames = strFileNames & "," & sFile
sFile = Dir()
Loop
''Open each file found
For Each itm In Split(strFileNames, ",")
If itm <> "" Then
Set wb = Workbooks.Open(sPath & itm)
''DO LOTS OF CALCULATIONS
'wb.Close True
End If
Next itm
Filesystemobject has a method for extracting the base name from a filename:
Msgbox createobject("scripting.filesystemobject").getbasename("myTest.xlsx") 'myTest
There's lots of ways to get at what you need using split, right, left, mid, or even regex. It really depends on the makeup of the possible source strings and how much variation they contain.
Based soley on your example the following shows various manipulations with the last variable giving "2012"
Sub test()
fPath = "P:\...\Annual and Quarterly Budget Data\ECMQA 2012Q1.xls"
fArray = Split(fPath, "\")
fnamewithtext = fArray(UBound(fArray))
fnamewithoutext = Split(fArray(UBound(fArray)), ".")(0)
ifannual = Left(Split(fArray(UBound(fArray)), " ")(1), 4)
End Sub
I already have a macro that creates sheets and some other stuff. After a sheet has been created do I want to call another macro that copies data from a second excel (its open) to first and active excel file.
First I want to copy to headers, but I cant get that to work - keep getting errors.
Sub CopyData(sheetName as String)
Dim File as String, SheetData as String
File = "my file.xls"
SheetData = "name of sheet where data is"
# Copy headers to sheetName in main file
Workbooks(File).Worksheets(SheetData).Range("A1").Select # fails here: Method Select for class Range failed
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
End Sub
What is wrong ?
I really want to avoid having to make "my file.xls" active.
Edit: I had to give it up and copy the SheetData to target file as a new sheet, before it could work.
Find and select multiple rows
Two years later (Found this on Google, so for anyone else)... As has been mentioned above, you don't need to select anything. These three lines:
Workbooks(File).Worksheets(SheetData).Range("A1").Select
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
Can be replaced with
Workbooks(File).Worksheets(SheetData).Range(Workbooks(File).Worksheets(SheetData). _
Range("A1"), Workbooks(File).Worksheets(SheetData).Range("A1").End(xlToRight)).Copy _
Destination:=ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
This should get around the select error.
Best practice is to open the source file (with a false visible status if you don't want to be bother) read your data and then we close it.
A working and clean code is avalaible on the link below :
http://vba-useful.blogspot.fr/2013/12/how-do-i-retrieve-data-from-another.html
Would you be happy to make "my file.xls" active if it didn't affect the screen? Turning off screen updating is the way to achieve this, it also has performance improvements (significant if you are doing looping while switching around worksheets / workbooks).
The command to do this is:
Application.ScreenUpdating = False
Don't forget to turn it back to True when your macros is finished.
I don't think you need to select anything at all. I opened two blank workbooks Book1 and Book2, put the value "A" in Range("A1") of Sheet1 in Book2, and submitted the following code in the immediate window -
Workbooks(2).Worksheets(1).Range("A1").Copy Workbooks(1).Worksheets(1).Range("A1")
The Range("A1") in Sheet1 of Book1 now contains "A".
Also, given the fact that in your code you are trying to copy from the ActiveWorkbook to "myfile.xls", the order seems to be reversed as the Copy method should be applied to a range in the ActiveWorkbook, and the destination (argument to the Copy function) should be the appropriate range in "myfile.xls".
I was in need of copying the data from one workbook to another using VBA. The requirement was as mentioned below 1. On pressing an Active X button open the dialogue to select the file from which the data needs to be copied. 2. On clicking OK the value should get copied from a cell / range to currently working workbook.
I did not want to use the open function because it opens the workbook which will be annoying
Below is the code that I wrote in the VBA. Any improvement or new alternative is welcome.
Code: Here I am copying the A1:C4 content from a workbook to the A1:C4 of current workbook
Private Sub CommandButton1_Click()
Dim BackUp As String
Dim cellCollection As New Collection
Dim strSourceSheetName As String
Dim strDestinationSheetName As String
strSourceSheetName = "Sheet1" 'Mention the Source Sheet Name of Source Workbook
strDestinationSheetName = "Sheet2" 'Mention the Destination Sheet Name of Destination Workbook
Set cellCollection = GetCellsFromRange("A1:C4") 'Mention the Range you want to copy data from Source Workbook
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
'.Filters.Add "Macro Enabled Xl", "*.xlsm;", 1
For intWorkBookCount = 1 To .SelectedItems.Count
Dim strWorkBookName As String
strWorkBookName = .SelectedItems(intWorkBookCount)
For cellCount = 1 To cellCollection.Count
On Error GoTo ErrorHandler
BackUp = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount))
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = GetData(strWorkBookName, strSourceSheetName, cellCollection.Item(cellCount))
Dim strTempValue As String
strTempValue = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)).Value
If (strTempValue = "0") Then
strTempValue = BackUp
End If
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = strTempValue
ErrorHandler:
If (Err.Number <> 0) Then
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = BackUp
Exit For
End If
Next cellCount
Next intWorkBookCount
End With
End Sub
Function GetCellsFromRange(RangeInScope As String) As Collection
Dim startCell As String
Dim endCell As String
Dim intStartColumn As Integer
Dim intEndColumn As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim coll As New Collection
startCell = Left(RangeInScope, InStr(RangeInScope, ":") - 1)
endCell = Right(RangeInScope, Len(RangeInScope) - InStr(RangeInScope, ":"))
intStartColumn = Range(startCell).Column
intEndColumn = Range(endCell).Column
intStartRow = Range(startCell).Row
intEndRow = Range(endCell).Row
For lngColumnCount = intStartColumn To intEndColumn
For lngRowCount = intStartRow To intEndRow
coll.Add (Cells(lngRowCount, lngColumnCount).Address(RowAbsolute:=False, ColumnAbsolute:=False))
Next lngRowCount
Next lngColumnCount
Set GetCellsFromRange = coll
End Function
Function GetData(FileFullPath As String, SheetName As String, CellInScope As String) As String
Dim Path As String
Dim FileName As String
Dim strFinalValue As String
Dim doesSheetExist As Boolean
Path = FileFullPath
Path = StrReverse(Path)
FileName = StrReverse(Left(Path, InStr(Path, "\") - 1))
Path = StrReverse(Right(Path, Len(Path) - InStr(Path, "\") + 1))
strFinalValue = "='" & Path & "[" & FileName & "]" & SheetName & "'!" & CellInScope
GetData = strFinalValue
End Function