Use VBA to Grab Only Part of a Filename/Filepath - vba

I'm not sure how to tackle this issue. I've done quite a bit of research, but most of the answers I find are a little different than what I need.
What I'm trying to accomplish is this:
Open up an existing workbook manually (wbAI),
Start macro,
Use msoFileDialogOpen to find and open a file (call this wb2),
Store part of wb2's file name (there is a date in the file name) as a variable or string. (I'm not sure which is better for this purpose. Maybe I don't need to store it all...),
Paste part of wb2's filename (the date) in a certain cell in wb1,
Copy the necessary data from wb2,
Paste the data in wb1,
Format the data,
Use a VLOOKUP on the pasted data,
Close wb2 without saving
End the macro.
My macro can do every step listed above except for numbers four and five. On one hand, I'm wondering how I need to pursue this, and on the other hand, I'm wondering where this would fit inside my current code.
To give you an example of what I'm talking about: let's say that in step three I open up a workbook that's named "01.31.13 Group Names." And the file path is from a Sharepoint site so it looks like this:
"https://company.com/team/teamone/_layouts/xlviewer.aspx?01.31.13%20Group%20Names%20.xlsm&Source=https......."
How can I pick out only the date in the filename/filepath?
Here's the beginning of my code:
Sub Test()
Dim lastRow As Long, i As Long
Dim ws As Worksheet
Dim wbSource As Workbook
Dim wbAI As Workbook
Dim vrtSelectedItem As Variant
Set wbAI = ActiveWorkbook
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = https://company.com/team/teamone & "\"
.AllowMultiSelect = False
.Show
' ****** Is this where the new code could be inserted? *******
For Each vrtSelectedItem In .SelectedItems
Set wbSource = Workbooks.Open(vrtSelectedItem)
Next
End With
' Check if the first cell contains data. If not then close file
If Range("Profile!H9") = "" Then
ActiveWorkbook.Close savechanges:=False
ActiveWorkbook.Saved = False
Any suggestions are welcome! Thank you for your time!
Edit: This is how my code looks after Philip's suggestion:
Sub Test()
Dim lastRow As Long, i As Long
Dim ws As Worksheet
Dim wbSource As Workbook
Dim wbAI As Workbook
Dim vrtSelectedItem As Variant
Set wbAI = ActiveWorkbook
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = https://company.com/team/teamone & "\"
.AllowMultiSelect = False
.Show
For Each vrtSelectedItem In .SelectedItems
Set wbSource = Workbooks.Open(vrtSelectedItem)
Next
End With
dateVar = Left(wbSource.Name, 8) '<~~~~ New code
' Check if the first cell contains data. If not then close file
If Range("Profile!H9") = "" Then
ActiveWorkbook.Close savechanges:=False
ActiveWorkbook.Saved = False
Else
Sheets("Profile").Activate
Range("H9:I" & Cells(Rows.Count, "H").End(xlUp).Row).Select
Selection.Copy
Windows("wbName").Activate
Sheets("Sheet1").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E1").Value = dateVar '<~~~ New code

from the filename you would use the LEFT FUNCTION to return the LEFT 8 chars of the date:
dateVar=left(wbSource.name, 8)
then you can put that in your cell:
rangeVar.value=dateVar
hope that gets you going
Philip

Related

Macro to loop through all worksheets except the first two and copy a cell and range into another workbook

I have a master workbook that I have that already looks through all the files in a folder. However, one of the tabs needs to look through all the tabs in a different selected workbook "Data". The workbook has roughly 30 worksheets, and I need to loop through each worksheet except "Investments" and "Funds". If it makes it easier these are the first two tabs in the workbook. I then need to copy cell F9 in each worksheet, paste it into a different workbook "Master" cell "C4", go back to the same worksheet in the "data" workbook and copy range "C16:C136" and paste that into cell "E4" of the "master" workbook. Then it would need to loop to the next worksheet in the "data" workbook and continue the loop. For each new worksheet, I need it to paste one row lower in the "master" file. i.e. the second worksheet would paste in "C5" and "E5".
If it makes it easier I can split this up into two macros. And Just paste all the data from the worksheets into a new blank sheet in the data work book and then I can have another one to copy all of that over into the "master" workbook once done.
Thanks in Advance
Sub ImportInformation()
WorksheetLoop
End Sub
Function WorksheetLoop()
Dim wb As Workbook
Dim ws As Worksheet
Dim foundCell As Range
Dim strFind As String
Dim fRow, fCol As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' This allows you to use excel functions by typing wf.<function name>
Set wf = WorksheetFunction
'Set the name of your output file, I assume its fixed in the Master File
‘Please note that I am running this out of the master file and I want it all in the Noi tab
Set NOI = ThisWorkbook.Worksheets("NOI")
'Retrieve Target File Path From User
Set FilePicker = Application.FileDialog(msoFileDialogFolderPicker)
‘This only selects a folder, however I would like it to select a SPECIFIC FILE
With FilePicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
' initialize the starting cell for the output file
pasterow = 4
‘I need this to be referring to the file that I choose
For Each ws In wb.Worksheets
If ws.Name <> "Funds" And ws.Name <> "Investments" Then
Next ws
Wb.Worksheets.Range.("F9").Copy
NOI.Range("C" & pasterow).PasteSpecial xlPasteValues, Transpose:=False
'Get find String
strFind = NOI.Range("C2").Value
'Find string in Row 16 of each row of current ACTIVE worksheet
Set foundCell = wb.Worksheets.Range("A16:IT16").Find(strFind, LookIn:=xlValues)
'If match cell is found
If Not foundCell Is Nothing Then
'Get row and column
fRow = foundCell.Row
fCol = foundCell.Column
'Copy data from active data worksheet “data” and copy over 300 columns (15 years).
‘ This is needed to find what specific date to start at. This portion works, I just need it to loop through each worksheet.
wb.Worksheets.active.Range(Cells(fRow + 1, fCol).Address & ":" & Cells(fRow + 1, fCol + 299).Address).Copy
'Paste in NOI tab of mater portfolio
NOI.Range("E" & pasterow).PasteSpecial xlPasteValues, Transpose:=False
wb.Application.CutCopyMode = False
Else
Call MsgBox("Try Again!” vbExclamation, "Finding String")
End If
Next Ws
wb.Close SaveChanges:=False
End Function
Please show us your first attempt. Feel free to put in comments like
' I need this to do XXXX here, but I don't know how
Here are a some hints:
To loop through all sheets in a workbook, use:
For each aSheet in MyWorkbook.Sheets
To skip some specific sheets, say:
If aSheet.Name <> "Investments" And aSheet.Name <> "Funds"
To copy from aSheet to MasterSheet, start by setting the initial destinations:
set rSource = aSheet.range("F9")
set rDestin = MasterSheet.range("C4")
Then in your loop you do the copy:
rDestin.Value = rSource.Value
...and set up the next set of locations
set rSource = rSource.offset(1,0)
set rDestin = rDestin.offset(1,0)
Does that help?
EDIT: Briefly looking at your version, I think this part won't work:
If ws.Name <> "Funds" And ws.Name <> "Investments" Then
Next ws
Don't you want to delete that last line?
EDIT 2: You use this a lot:
wb.Worksheets.<something>
But that does not refer to a specific worksheet. You want to use "ws", like this:
ws.Range("F9")
BIG EDIT:
Step through this version carefully and see how it works:
Sub ImportInformation()
WorksheetLoop
End Sub
Function WorksheetLoop()
Dim wb As Workbook
Dim ws As Worksheet
Dim foundCell As Range
Dim strFind As String
Dim fRow, fCol As Integer
'*** Adding Dims:
Dim wf, FilePicker
Dim NOI As Worksheet
Dim myPath As String
Dim PasteRow As Long
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' This allows you to use excel functions by typing wf.<function name>
Set wf = WorksheetFunction
'Set the name of your output file, I assume its fixed in the Master File
'Please note that I am running this out of the master file and I want it all in the Noi tab
Set NOI = ThisWorkbook.Worksheets("NOI")
'Retrieve Target File Path From User
' Set FilePicker = Application.FileDialog(msoFileDialogFolderPicker)
'This only selects a folder, however I would like it to select a SPECIFIC FILE
' With FilePicker
' .Title = "Select A Target Folder"
' .AllowMultiSelect = False
' If .Show <> -1 Then GoTo NextCode
' myPath = .SelectedItems(1) & "\"
' End With
Dim WorkbookName As Variant
' This runs the "Open" dialog box for user to choose a file
WorkbookName = Application.GetOpenFilename( _
FileFilter:="Excel Workbooks, *.xl*", Title:="Open Workbook")
Set wb = Workbooks.Open(WorkbookName)
' initialize the starting cell for the output file
PasteRow = 4
'I need this to be referring to the file that I choose
For Each ws In wb.Worksheets
If ws.Name <> "Funds" And ws.Name <> "Investments" Then
' **** Leave this out: Next ws
ws.Range("F9").Copy '<--- You mean this, not wb.Worksheets.Range.("F9").Copy
NOI.Range("C" & PasteRow).PasteSpecial xlPasteValues, Transpose:=False
'Get find String
strFind = NOI.Range("C2").Value
'Find string in Row 16 of each row of current ACTIVE worksheet
Set foundCell = ws.Range("A16:IT16").Find(strFind, LookIn:=xlValues)
'If match cell is found
If Not foundCell Is Nothing Then
'Get row and column
fRow = foundCell.Row
fCol = foundCell.Column
'Copy data from active data worksheet “data” and copy over 300 columns (15 years).
' This is needed to find what specific date to start at. This portion works, I just need it to loop through each worksheet.
ws.Range(Cells(fRow + 1, fCol).Address & ":" & Cells(fRow + 1, fCol + 299).Address).Copy
'Paste in NOI tab of mater portfolio
NOI.Range("E" & PasteRow).PasteSpecial xlPasteValues, Transpose:=False
'*** Move PasteRow down by one
PasteRow = PasteRow + 1
wb.Application.CutCopyMode = False
Else
Call MsgBox("Try Again!", vbExclamation, "Finding String")
End If
End If
Next ws
wb.Close SaveChanges:=False
End Function

my code merging all workbooks into seperate sheets. i need to merge all in 1 same sheet

I tried to merge the workbooks by browsing and selecting multiple workbooks time and getting all data in current workbook. I need all data of selected workbooks in 1 sheet.But my code gives in different sheets of current workbook. sheets.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count) as per this line,syntax allowing me to opt either after or before but not giving current. pls help me out
Dim files, i As Integer
Dim dailogbox As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim sheets As Worksheet
Set mainWorkbook = Application.ActiveWorkbook
Set dailogbox = Application.FileDialog(msoFileDialogFilePicker)
dailogbox.AllowMultiSelect = True
files = dailogbox.Show
For i = 1 To dailogbox.SelectedItems.Count
Workbooks.Open dailogbox.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
For Each sheets In sourceWorkbook.Worksheets
sheets.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet
sourceWorkbook.Close
Next i
As you have discovered, Sheets.Copy will copy or move the entire sheet. It will not merge the data into another sheet. You will have to copy the cells of the sheet you want to copy,
dim dest as Range
For i = 1 To dailogbox.SelectedItems.Count
Workbooks.Open dailogbox.SelectedItems(i)
Set sourceWorkbook = Workbooks.Open(dailogbox.SelectedItems(i))
For Each aSheet In sourceWorkbook.Worksheets '
set dest = mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
aSheet.Cells.Copy dest.Cells
Next sheets ' NOT "tempWorkSheet"
sourceWorkbook.Close
Next i
Also: "Sheets" is a reserved word. You can't use it as a variable. I changed it to "aSheet".
EDIT: To copy the formatting after copying the text, add this after aSheet.Cells.Copy dest.Cells:
dest.PasteSpecial Paste:=xlPasteFormats
This will open a file dialog allowing you to select multiple files, it will then cycle through each sheet on the work books, copy the data from A2 to the bottom right corner of your data, and paste it in the workbook that hosts this code.
Things you will need to modify or amend for:
1) The sheet name of your book that hosts this code
2) The Col span (A-Z right now)
3) If your import books have multiple sheets, you need to set a criteria for which sheets you want to import since this will grab every sheet from every selected workbook.
4) This assumes Col A does not have any blanks (to determine last row (what range to copy) you need to pick a column that is least likely to have blanks so you dont miss data.
Option Explicit
Sub Consolidation()
Dim CurrentBook As Workbook
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("SHEETNAME?")
Dim IndvFiles As FileDialog
Dim FileIdx As Long
Dim i As Integer, x As Integer
Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
With IndvFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For FileIdx = 1 To IndvFiles.SelectedItems.Count
Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx))
For Each Sheet In CurrentBook.Sheets
Dim LRow1 As Long
LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
Dim LRow2 As Long
LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row
Dim ImportRange As Range
Set ImportRange = CurrentBook.ActiveSheet.Range("A2:Z" & LRow2)
ImportRange.Copy
WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next
CurrentBook.Close False
Next FileIdx
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
maybe you're after this (explanations in comments):
Option Explicit
Sub CopySheets()
Dim files As Variant, i As Long
Dim dailogbox As FileDialog
Dim mySheet As Worksheet, targetSheet As Worksheet
Set targetSheet = ActiveSheet ' set the sheet you want to collect selecte workbooks worksheets data into
Set dailogbox = Application.FileDialog(msoFileDialogFilePicker)
dailogbox.AllowMultiSelect = True
files = dailogbox.Show
For i = 1 To dailogbox.SelectedItems.Count
With Workbooks.Open(dailogbox.SelectedItems(i)) ' open and reference current workbook
For Each mySheet In .Worksheets ' loop through current workbook worksheets
mySheet.UsedRange.Copy targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Offset(1) ' copy current worksheet "used" range and paste them into target sheet from its column A first empty cell after last not empty one
Next
.Close False ' cloe current workbook, discarding changes
End With
Next
End Sub

Excel Copy From WB to another WB and other

I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to simplify and make my code more efficient. It's working but It's longer and longer day after day because of the amount of data/traffic at certain hours on the company network.
I know it's not correct to use "Select" but I didn't find an answer to my problem.
Situation:
I created my layout on SAP, and I export them (default file name is
'Export.xls')
I go to my Main Excel File (called 'Dashboard') and I
run the code from the WS concerned by the layout exported
The username need to be captured in case I'm out of office, and someone else need to run the code.
When Data are imported from SAP Export to my main file, it closes the SAP "Export" file
This is my current code:
Sub PasteSAP()
'
' Pull Data From SAP Export - Excel File
'
Dim UserName As String
UserName = Environ("username")
'Clear "PasteSAP" sheet in case the next one will have less data
Range("A:O").Select
Selection.ClearContents
'Open SAP Excel file (the export)
Workbooks.Open "C:\Users\" & UserName & "\Desktop\export.XLSX"
Windows("export.XLSX").Activate
'Copy data of the SAP Excel file
Range("A:O").Select
Selection.Copy
'Go back to the main file and paste in the active worksheet
Windows("Dashboard - 2017.xlsm").Activate
Range("A:O").Select
ActiveSheet.Paste
'Close SAP Excel file
Windows("export.XLSX").Activate
Application.DisplayAlerts = False
ActiveWindow.Close
'Change Format
Range("A:A").Select 'specify the range which suits your purpose
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 7).NumberFormat = "General"
wks.Cells(r, 9).Style = "Currency"
End If
Next r
Range("A1").Select
End Sub
Since you are copying the whole columns you do not Need to erase them beforehand.
Usually you would not want to jump between windows since it takes lots of time.
Also turning off ScreenUpdating could speed things up.
Try the following code:
...
Application.ScreenUpdating = False
dim wb_export as Workbook
dim ws_export_from as Worksheet, ws_export_to as Worksheet
Set wb_export = Workbooks.open("...\Export.xls")
Set ws_export_from = wb_export.Worksheets("your worksheet")
Set ws_export_to = Worksheets("Destination worksheet")
ws_export_from.range("A:O").Copy Destination := ws_export_to.Range("A:O")
wb_export.close false
set wb_export = Nothing
set ws_export_from = Nothing
set ws_export_to = Nothing
Application.ScreenUpdating = True
This should run a lot faster.

VBA run from my PERSONAL wb is perfect, copied to a distro wb and it breaks. Why?

I have the following code in a macro in my personal book, and it works perfectly.
I'm trying to copy it into the actual wb it's running from so I can send it around for others to use, and it's breaking at the commented line "XXXXXX". The selected wb is being opened fine, but none of the subsequent editing occurs to that book. All of the following code (deletion of columns, etc) that should be happening to the opened workbook only happens to the wb running the macro, which is...sub-optimal.
I don't know why! Any thoughts welcomed.
Thank you
Sam
Sub PredictBoxValue()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim TitleName As String
Dim sas As String
Dim sos As String
Dim unusedRow As Long
Dim filename As String
'Optimize Macro Speed
Application.ScreenUpdating = False
'Application.EnableEvents = False
'Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
sos = ActiveWorkbook.Name
ActiveSheet.Range("B11", "AF11").Clear
Dim fNameAndPath As Variant
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLS),
*.XLS", Title:="Select File To Be Opened")
If fNameAndPath = False Then Exit Sub
Set wb = Workbooks.Open(fNameAndPath)
sas = ActiveWorkbook.Name
'Delete extraneous columns and rows
'XXXXXXXXXXX
TitleName = Cells(5, 2).Value
Columns(8).Delete
Columns(12).Delete
Columns(12).Delete
Columns(3).Delete
Columns(2).Delete
Columns(1).Delete
Rows(3).Delete
Rows(2).Delete
Rows(1).Delete
Here:
Do Until Cells(2, 1).Value = "1"
Range("A1").End(xlDown).Select
'Do Until ActiveCell.Value = "1"
'ActiveCell.Offset(1).Select
'Loop
Do While ActiveCell.Value < 1
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Loop
ActiveCell.Offset(-1, 1).Select
Do While ActiveCell.Offset(0, -1).Value > 30
ActiveCell.EntireRow.Delete
GoTo Here
Loop
ActiveCell.Resize(, 7).Cut ActiveCell.Offset(1, 0).End(xlToRight).Offset(0,
1)
ActiveCell.EntireRow.Delete
Loop
Rows(1).EntireRow.Delete
Cells(1, 1) = TitleName
Range("A1", Range("A1").End(xlToRight)).Copy
Windows(sos).Activate
ActiveSheet.Cells(11, 2).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Windows(sas).Activate
'Save and Close Workbook
wb.Close SaveChanges:=False
Windows(sos).Activate
ActiveSheet.Cells(5, 3).Select
'Message Box when tasks are completed
MsgBox ("Data uploaded for ") & Range("B11")
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I took a bit of a closer look at your code. I think you are saying that you want to run code from macros.xlsm (or something like that), and have it operate on mydata.xlsx (or some such). Therefore, in your macro, ThisWorkbook will refer to macros.xlsm (should you need to refer to that).
After you have done Set wb = Workbooks.Open(fNameAndPath) to open mydata.xlsx, only and always refer to wb and wb.Sheets("whatever") when you are talking about mydata.xlsx.
Don't use Columns, Rows, Sheets, or Cells without a sheet reference in front of them
Don't use ActiveWorkbook/ActiveWorksheet at all.
Instead of ActiveCell, use a named range, e.g., as in this answer to the question BruceWayne noted.
That should take care of it!
<soapbox>And, in general, please be careful of your indentation and use longer variable names — both will help you avoid bugs as you work on this code.</soapbox>

Copy data from a given filename/path vba

I'm trying to create an excel tool where it would extract data from a given filename(workbook). Let's say, on my main workbook in(Sheet1-Cell A1), users will enter the filename. Then on a cmdbutton click, it'll copy the data from that specific filename(workbook).
I have created a file that copies data from another workbook, however, it indicates the specific path & filename of the workbook where the data will be copied.
Dim myData As Workbook
Set myData = Workbooks.Open("C:\Users\Desktop\Book2.xlsx")
Call Sample
Selection.Copy
What I want, is to allow users to just enter the filename, then excel will locate that file, select data from there & copy it on the main workbook(Sheet2).
I figured something out
Sub copydata()
Dim path As String
path = InputBox("Please input path")
Application.ScreenUpdating = False
Dim actualfile As Workbook
Set actualfile = ActiveWorkbook
Dim script As Object
Set script = CreateObject("Scripting.FileSystemObject")
Dim catalogue As Object
Set catalogue = script.GetFolder(path)
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Dim textfile As Object
For Each textfile In catalogue.Files
Workbooks.Open textfile
Dim loadedfile As Workbook
Set loadedfile = ActiveWorkbook
loadedfile.Worksheets(1).Range("A2").CurrentRegion.Offset(1, 0).Copy
actualfile.Worksheets(1).Range("A2").Offset(1, 0).End(xlUp).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
loadedfile.Close Savechanges:=False
Next textfile
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
End Sub
The only problem though is, it copies data to the column after the heading instead of copying it to the row below the heading - help on this is very much appreciated! :)