excel vba move multiple files using listbox - excel

I have created a form with three list boxes. The first loads with the files in a selected folder. I then select several files in the first list and move them into the second list box. The files in the second list box now need to be copied into folders listed in the third list box. All the issues of setting the source and destination paths are done. I need the lines of code which cause the selected files in the second list to be copied to the selected destination in the third list box.
Sample code:
FileToCopy = FileSourceDirectory & lstSelectedFiles.Value
DestinationFolderName = UserRepositoryDirectory & lstRepositoryFolders
CopiedFile = DestinationFolderName & "\" & lstSelectedFiles.Value
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
FileCopy FileToCopy, CopiedFile Unload frmCopyFileToRepository

Dim i As Integer
For i = 0 To lstSelectedFiles.ListCount - 1
FileToCopy = FileSourceDirectory & lstSelectedFiles.List(i)
CopiedFile = DestinationFolderName & "\" & lstSelectedFiles.List(i)
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
FileCopy FileToCopy, CopiedFile
Next i

Related

Looping Issue with VBA Macro in Excel

I am writing a macro that gets data from two separate locations and pastes it into a template, saves the template as a new file, then loops back and repeats the process. The macro works for one file but fails when looping. Specifically, the computer can't find the file and thinks it has been moved or deleted.
Here is the code:
'sub and dims excluded to save space
'set folder locations
dataFolder = "C:\Location\" 'abbreviated
previousFolder = "C:\Other Location\" 'abbreviated
'set file names
dataFile = Dir(dataFolder & "*.xls*")
previousFile = Dir(previousFolder & "*.xls*")
Do While dataFile <> ""
Set dataWB = Workbooks.Open(dataFolder & dataFile)'this is where the code breaks on looping
'the contents of the loop work fine on the first go so I am excluding them
'Save file to directory
ActiveWorkbook.SaveAs ("C:\Save Location\")
'how I am ending the loop
dataFile = Dir
previousFile = Dir
Loop
End Sub`
I hope this is sufficiently clear. To be even more concise:
dataFile = Dir(dataFolder & "*.xls*")
previousFile = Dir(previousFolder & "*.xls*")
Do While dataFile <> "" 'breaks here after succeeding with first file
'stuff to do
dataFile = Dir
previousFile = Dir
Loop
I was expecting the program to grab the next file in the source folder and repeat the process but instead it breaks saying it can't find the next file (even though it returns the files name in that error message).
If you push the file loop out into a separate function it's easier to deal with multiple file locations:
Sub tester()
Dim files As Collection, filesPrev As Collection
Set files = MatchedFiles("C:\Temp\", "*.xls*")
Set filesPrev = MatchedFiles("C:\Temp\Previous\", "*.xls*")
Debug.Print files.Count, filesPrev.Count
'do something with file names in the collections
End Sub
'Return a collection of file paths
Function MatchedFiles(ByVal fldr As String, pattern As String) As Collection
Dim f
If Right(fldr, 1) <> "\" Then fldr = fldr & "\"
Set MatchedFiles = New Collection
f = Dir(fldr & pattern)
Do While Len(f) > 0
MatchedFiles.Add fldr & f
f = Dir()
Loop
End Function

Search windows, returns filepath

OK, so I have code that will take the data entered in "A3" and open a widows search with "*" + A3's contents. What I need now is when any file is found with that search to find the folder name that houses it. Basically we have prints stored by a random number not associated to the real part number but all the related prints are stored within this random numbered folder.
Example:
C:\Document Control\Master Prints*12345*\printxyz.pdf
If I were to search for "*xyz" and "printxyz.pdf" shows up, I now need the "12345" folder name to populate in a cell.
Here is what im using so far
Sub Macro4()
Dim var As Variant
var = "*" & Range("A3").Value
Call Shell("explorer.exe " & Chr(34) & "search-ms:query=" & var & "&crumb=location:""C:\Document Control\Master Prints" & Chr(34), vbNormalFocus)
End Sub
I did something similar recently. I had words in cell E1 that pertains to files in a folder. So I did an instr on the first 5 letters of that cell as my search then looped through the folder to find the file containing that string.
You should be able to adapt this code to what you need.
Const parentFolder As String = "I:\this\that\"
subFolder = parentFolder & getFoldPath(parentFolder, Left(.Range("E1"), 5)) & "\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(subFolder)
For Each oFile In oFolder.Files
If InStr(oFile, Left(.Range("E1"), 5)) > 0 Then
scope = subFolder & oFile.name
End If
Next

Pulling file names from SharePoint and saving to SharePoint, using VBA

I'm trying to adapt an Excel form I created that uses drive locations to save copies of the form, to work with SharePoint in a similar manner. Currently, the first macro is set up such that it will search the contents of a particular folder to determine the next available number in the queue (i.e. if 1, 2 and 4 already exist, it will assign 3) and save the sheet as that next available number. When the sheet is complete, the second macro will save the file with a specified name based on data within the sheet, in another specified location (again based on data defined within the sheet). The drive is in the process of being retired in our company and everything moved to Cloud-based storage, so I would like a way to complete the same actions but using SharePoint directories.
The code for the first macro is as follows:
Dim strDir As String
Dim file As Variant
Dim savename As Integer
Dim savename_string As String
strDir = "R:\Queue\"
savename = 1
savename_string = CStr(savename)
file = Dir(strDir)
While (CInt(savename_string) = savename)
If file <> (savename & ".xlsm") Then
If file = "" Then
savename = savename + 1
Else
file = Dir
End If
ElseIf file = (savename & ".xlsm") Then
savename = savename + 1
savename_string = CStr(savename)
file = Dir(strDir)
End If
Wend
ActiveWorkbook.SaveAs ("R:\Queue\" & savename_string & ".xlsm")
And then the code for the second macro is as follows:
Dim answer As Integer
Dim error As Integer
Dim delete As String
answer = MsgBox("Are you sure you want to save sheet & close?", vbYesNo + vbQuestion, "WARNING")
If answer = vbYes Then
'Define PWO, assembly, terminal, strand, and gauge As Strings, and define which cells they are on the sheet
delete = ActiveWorkbook.Name
ActiveWorkbook.SaveAs ("R:\" & terminal & assembly & Space(1) & gauge & strand & Space(1) & PWO & Space(1) & Format(Now(), "MM-DD-YYYY") & ".xlsm")
Kill ("R:\Queue\" & delete)
ActiveWorkbook.Close
Else
Exit Sub
End If
Currently the second macro works correctly when replacing the locations with the SharePoint URL locations, but when doing the same with the first macro, it returns an error message "Bad file name or number" at the line file = Dir(strDir). Can I get this code in working order, or is there a better way I should go about this? Thanks!

Excel VBA Dir() Error when file type changes

I'm trying to better understand the Dir function. I have a Dir loop to take action on all .csv files in the directory, but when the loop comes across another file type, like .txt, it will error instead of moving on to the next .csv. item.
This is the relevant portion of my code.
strSourceExcelLocation = "\\rilinfs001\Interdepartmental\Billings & Deductions\Billing Coordinators\MCB Reports\East\Monthly Quality MCBs (CMQ & SECMQ)\2019\Individual_Reports\" & fldr & "\"
strWorkbook = Dir(strSourceExcelLocation & "*.csv*")
Do While Len(strWorkbook) > 0
'Open the workbook
Set wbktoExport = Workbooks.Open(Filename:=strSourceExcelLocation & strWorkbook)
'Export all sheets as single PDF
Call Export_Excel_as_PDF(wbktoExport)
'Get next workbook
strWorkbook = Dir
'Close Excel workbook without making changes
wbktoExport.Close False
Loop
So if there are only .csv files in the directory, then this works fine. When it comes across another file type, an error occurs.
The error is on line
strWorkbook = Dir
Run-time error 5: Invalid procedure call or argument
Am I missing something with the way I use the wildcards in the .csv at the beginning?
Thank you
Solved my issue.
The problem seems to have been because when I called another procedure, I had another Dir in that sub to create a new folder if one didn't already exist. So basically I had a Dir in a Dir, which apparently is bad.
I moved the folder creation part to the very beginning of my procedure, so it is executed before I begin the Dir for looping through all the CSV files.
Option Explicit
Sub Loop_Dir_for_Excel_Workbooks()
Dim strWorkbook As String, wbktoExport As Workbook, strSourceExcelLocation As String, fldr As String, strTargetPDFLocation As String, d As String
strTargetPDFLocation = "\\nhchefs001\Accounting\IMAGING\BILLINGS & DEDUCTIONS\EAST MCB FILES\"
'***** Creating a folder to save the PDFs in. Naming the folder with today's date *****
d = Format(Date, "mm-dd-yyyy")
strTargetPDFLocation = "\\nhchefs001\Accounting\IMAGING\BILLINGS & DEDUCTIONS\EAST MCB FILES\" & d & "\"
If Len(Dir(strTargetPDFLocation, vbDirectory)) = 0 Then MkDir strTargetPDFLocation
fldr = InputBox("Input the EXACT Folder Name that you want to create PDFs for")
strSourceExcelLocation = "\\rilinfs001\Interdepartmental\Billings & Deductions\Billing Coordinators\MCB Reports\East\Monthly Quality MCBs (CMQ & SECMQ)\2019\Individual_Reports\" & fldr & "\"
'Search all Excel files in the directory with .xls, .xlsx, xlsm extensions
strWorkbook = Dir(strSourceExcelLocation & "*.csv")
Do While Len(strWorkbook) > 0
'Open the workbook
Set wbktoExport = Workbooks.Open(Filename:=strSourceExcelLocation & strWorkbook)
'Export all sheets as single PDF
Call Export_Excel_as_PDF(wbktoExport, strTargetPDFLocation)
'Close Excel workbook without making changes
wbktoExport.Close False
'Get next workbook
strWorkbook = Dir
Loop
End Sub
Try to hardcode the path and give it a try again. Probably the error is something really small in the hardcoding. E.g., in the code below, replace C:\Users\username\Desktop\AAA\ with the path of the file. Then run it. Do not forget the last \. It should work:
Sub TestMe()
Dim workbookPath As String
workbookPath = Dir("C:\Users\username\Desktop\AAA\" & "*.csv")
Do While Len(workbookPath) > 0
Debug.Print workbookPath
workbookPath = Dir
Loop
End Sub

EXCEL: How to create folders that autoupdate as I insert a new value?

I want to create folders with Excel, in a way that every time a make a new entry in the selected column, a new folder is created.
I already searched and found some codes to VBA that creates the folders. But I have to select the cells and then run the macro everytime. Is there any way that I can do that automatically?
Thank you in advance,
Leo
Below is the code for creating new folders (Sub directories)
Sub CreateFolder()
Dim caminho As String
Dim folder As Object, FolderName
For i = 1 To 500
Set folder = CreateObject("Scripting.FileSystemObject") FolderName = ActiveWorkbook.Path & "\" & Range("A" & i).Value
If Not folder.FolderExists(FolderName) Then
folder.CreateFolder (FolderName)
End If
directory = ThisWorkbook.Path
Next i
End Sub
Yes, we can help you. Just need some pertinent info. Does the column need to be selected? Or can you work with a hard coded column? Say a column like Column D... We can put a Worksheet_Change macro on your worksheet module so that whenever a value in a certain column is changed - it will automatically check to see if that folder exists and if not then create it.
Here is an example that will create folders for any new or changed cells in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim caminho As String
Dim folder As Object, FolderName
If Target.Column = 1 And Target.Value <> "" Then ' If Changed Cell is in Column A
' This code changes unacceptable file name characters with an underscore
Filename = Target.Value
MyArray = Array("<", ">", "|", "/", "*", "\", "?", """")
For X = LBound(MyArray) To UBound(MyArray)
Filename = Replace(Filename, MyArray(X), "_", 1)
Next X
' This code creates the folder if it doesn't already exist
Set folder = CreateObject("Scripting.FileSystemObject")
FolderName = ActiveWorkbook.Path & "\" & Filename
If Not folder.FolderExists(FolderName) Then
folder.CreateFolder (FolderName)
End If
End If
End Sub

Resources