Hello i have macro where download all attachments from multiple emails, this code works fine, but I need change code to change every file name where was downloaded in folder, files name like "I10001258", "I10003256", "I10004758"... I wanna delete first five letters "I10001258", for all downloading files. Thanks!
Option Explicit
Sub Get_Attachments()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim msg As Outlook.MailItem
Dim fo As Outlook.Folder
Dim at As Outlook.Attachment
Set fo = Outlook.GetNamespace("MAPI").Folders("Your Mail Box Name Here").Folders("Inbox").Folders("My Report")
Dim lr As Integer
For Each msg In fo.Items
lr = Application.WorksheetFunction.CountA(sh.Range("A:A"))
sh.Range("A" & lr + 1).Value = msg.Subject
sh.Range("B" & lr + 1).Value = msg.Attachments.Count
For Each at In msg.Attachments
If VBA.InStr(at.Filename, ".xls") > 0 Then
at.SaveAsFile sh.Range("F1").Value & "\" & at.Filename
End If
Next
Next
MsgBox "Reports have been downloaded successfully"
End Sub
Mid() can be used to skip the first characters.
at.SaveAsFile sh.Range("F1").Value & "\" & Mid(at.Filename, 6)
Related
I am creating an archiving system where I need to sort files into folders.
I create the folders automatically by mentioning the names of folder in an Excel sheet.
Now I need to copy the files with similar names in that respective folder.
E.g. A folder is created with the name "Ashley Davidson". All the files which are in one source folder and whose file name starts with Ashley Davidson should be copied to this folder.
There will be more than 500 folders and more than 10,000 files to be copied in these folders every week.
The code below creates the folders.
How can I copy the files based on similar name to these folders?
Important
The names of folders will be constant.
The start of the names of files will be similar but users add other words like date, age, sheet 1, sheet 2 etc., therefore List of Partial name concept will probably work here.
Examples of folder names
Example of file names
Code to create folders:
Sub MakeFolders()
Dim sh As Worksheet, lastR As Long, arr, i As Long, rootPath As String
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
arr = sh.Range("A2:A" & lastR).Value2
rootPath = ThisWorkbook.Path & "\"
For i = 1 To UBound(arr)
If arr(i, 1) <> "" And noIllegalChars(CStr(arr(i, 1))) Then
If Dir(rootPath & arr(i, 1), vbDirectory) = "" Then
MkDir rootPath & arr(i, 1)
End If
Else
MsgBox "Illegals characters or empty cell (" & sh.Range("A" & i + 1).Address & ")..."
End If
Next i
End Sub
Function noIllegalChars(x As String) As Boolean
Const illCh As String = "*[\/\\"":\*?]*"
If Not x Like illCh Then noIllegalChars = True
End Function
You did not answer the clarification question and I need to leave my office. The next code assumes that all files exist in a common folder and they should be moved in the folder exactly named as the string in column A:A of the active sheet. It is able to move or copy the file, according to the line you should uncomment:
Sub moveMatchedFilesInAppropriateFolders()
Dim sh As Worksheet, lastR As Long, filesPath As String, fileName As String, foldersRoot As String, folderPath As String
Dim arr, boolNotFound As Boolean, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).Value2
foldersRoot = ThisWorkbook.Path & "\" 'use here the root folder for folders
filesPath = "your files to be processed folder" 'use here the path where the files can be found
Set fso = CreateObject("Scripting.FileSystemObject") 'to check if file exists
For i = 1 To UBound(arr)
boolNotFound = False
If Dir(foldersRoot & arr(i, 1), vbDirectory) <> "" Then
folderPath = foldersRoot & arr(i, 1) & "\"
Else
MsgBox arr(i, 1) & " folder could not be found!" & vbCrLf & _
"Please, note and correct it after copying the matching ones and run the code again!"
boolNotFound = True
End If
If Not boolNotFound Then
fileName = Dir(filesPath & arr(i, 1) & "*.*")
Do While fileName <> ""
If Not fso.FileExists(folderPath & fileName) Then 'move/copy only if it does not exist in destination fld
'uncomment the way you need (moving or copying):
'Name filesPath & fileName As folderPath & fileName 'the file is moved
'FileCopy filesPath & fileName, folderPath & fileName 'the file is copied
End If
fileName = Dir
Loop
End If
Next i
End Sub
Not tested, but it should work.
If you need something else, please better answer my last clarifications question.
Besides all that, I think it would be good to place a marker in B:B column, for not found folders, if any. In this way, the code can be adapted that at the next run to only run the ones having the marker (and delete it, if the string has been corrected and the folder has been found).
My code works from having the new Folders in the same folder as the workbook you've created said folders from (as it is in your code) and the files to be copied were in a seperate folder in the same path as your workbook; I found that easier to work with since then the only files in that folder are files to be copied, not extra folders within.
Sub copyFilesToFolder()
Dim lRow As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim ccell As Range
Dim fsO As Object, oFolder As Object, oFile As Object
Dim pathFiles As String, sFolderPath As String, sSource As String, sDestination As String
Set wb = ActiveWorkbook
Set ws = wb.ActiveWorksheet
lRow = Range("A" & Rows.Count).End(xlUp).Row
pathFiles = "Q:\WHERE YOUR ORIGINAL WORKBOOK IS\Test\" 'could be gotten from wb technically
Set fsO = CreateObject("Scripting.FileSystemObject")
Set oFolder = fsO.GetFolder(pathFiles)
For Each oFile In oFolder.Files 'go through all the files
For Each ccell In Range("A2:A" & lRow).Cells 'go through all the folder-names
'Debug.Print ccell.Value2
'Debug.Print oFile.Name
If InStr(oFile.Name, ccell.Value2) > 0 Then 'if folder name is in file name
sFolderPath = wb.Path & "\" & ccell.Value2 & "\"
If Dir(sFolderPath, vbDirectory) <> "" Then 'if Folder exists
sDestination = sFolderPath & oFile.Name
If Dir(sDestination) = "" Then 'file doesn't exist yet
sSource = pathFiles & oFile.Name
'Debug.Print sSource
'Debug.Print sDestination
Call fsO.CopyFile(pathFiles & oFile.Name, sFolderPath & oFile.Name)
GoTo Skip
End If
Else
MsgBox ("Folder " & ccell.Value2 & " doesn't exist yet")
End If
End If
Next ccell
Skip:
Next oFile
End Sub
Hope this helps :)
firstly sorry if my english is not perfect as i'm french.
i'm new to this and i'm trying to make something work for my company to save some time.
i'd like to make a VBA code that Create a Folder with 9 sub folder inside but the tricky part i guess is that inside those 9 sub folders i need to have again sub folders.
i then need to auto copy an excel file to the main folder that have the same name
The Main folder name need to be based after 3 Excel row "A2" "C2" "B2"
Below a screenshot of inside the Main Folder :
I have some code that i found on the web that does some stuff that i need but i don't know how to do it.
Below code that i have :
Sub CreateDirs()
Dim r As Range
Dim RootFolder As String
RootFolder = Range("K2").Value
Range("A2").Select
For Each r In Range(Selection, Selection.End(xlDown))
If Len(r.Text) > 0 Then
On Error Resume Next
MkDir RootFolder & "\" & r.Text
MkDir RootFolder & "\" & r.Text & "\" & Range("L2").Value
MkDir RootFolder & "\" & r.Text & "\" & Range("L3").Value
MkDir RootFolder & "\" & r.Text & "\" & Range("L4").Value
On Error GoTo 0
End If
Next r
End Sub
combined with this code :
Sub File_Transfer()
'
Dim src As String, dst As String, fl As String
Dim lr As Long
'Source directory
'Range("A2").Select
lr = Cells(Rows.Count, "H").End(xlUp).Row
For X = 2 To lr
src = Range("F" & X).Value
'Destination directory
dst = Range("G" & X).Value
'Filename
fl = Range("E" & X).Value
On Error Resume Next
'get project id
FileCopy src & "\" & fl, dst & "\" & fl
If Err.Number <> 0 Then
End If
Next X
On Error GoTo 0
End Sub
Those 2 code will Create Folders with sub folders and will copy an excel file in the main folder but the Main folder is based only on one column
with this code i have this Excel Sheet :
I have this third code that will only create a Main Folder but with my name based on my 3 Column :
Sub ExampleCode()
Dim strName As String
Dim strCode As String
Dim strCode1 As String
Dim fName As String
Dim fPath As String
Dim lastRow As Long
Dim i As Long
Dim ws As Worksheet
'Where will we create these folders?
fPath = "C:\Users\WBRICET\Documents\TESTVBA"
'Error check
If Right(fPath, 1) <> Application.PathSeparator Then
fPath = fPath & Application.PathSeparator
End If
'What sheet has the data?
Set ws = ActiveSheet
Application.ScreenUpdating = False
With ws
'How much data do we have
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop from row 3 to end
For i = 3 To lastRow
'Get the bits
strName = .Cells(i, "A").Value
strCode = .Cells(i, "C").Value
strCode1 = .Cells(i, "B").Value
'Build folder name
fName = strName & " " & strCode & " " & strCode1
'Check if folder already exists
If Dir(fPath & fName, vbDirectory) = "" Then
'Create folder
MkDir fPath & fName
End If
Next i
End With
Application.ScreenUpdating = True
'Since nothing changed on sheet, provide feedback to user
MsgBox "Done!"
End Sub
Sorry for my long post but that would help me a lot in my work and my coworker too.
Thanks again :)
EDIT : if it's easier for the subfolders part could we not do something that copy existing exemple empty folders to the new one created ?
Like The VBA will Create a Folder based on 3 Column "XXX XXX XXX" copy the excel in main folder and also copy empty entire Subfolder "shell" that i normaly copy by hand"
Given a directory containing several thousands Outlook MSG files, I want to use Excel to read certain pieces of the message metadata and map it to a worksheet. However, VBA returns certain fields as blank, such as Sender.
I expect one attachment per email. I'm trying:
Sub SaveOlAttachments()
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim fpath As String
Dim outPath As String
Dim writeRow As Long
fpath="some\path"
outPath="some\path"
writeRow = 2
strFile = Dir(fpath & "\" & "*.msg")
Do While Len(strFile) > 0
Set Msg = objOL.Session.OpenSharedItem(fpath & "\" & strFile)
If Msg.Attachments.Count > 0 Then
For Each att In Msg.Attachments
att.SaveAsFile outPath & "\" & att.Filename
Cells(writeRow, 1).Value = Msg.Subject
Cells(writeRow, 2).Value = att.Filename
Cells(writeRow, 3).Value = Msg.SentOn
Next
End If
writeRow = writeRow + 1
strFile = Dir
Loop
End Sub
However, when looking at Msg in my Locals window, I get blank values for SenderEmailAddress, BCC, Body, Recipients.
I know this is wrong immediately upon opening any one of the emails.
It turns out that copying the files from my network drive into a folder in my Outlook inbox brought the values back to where I could see them again in Outlook.
Instead of making a workbook in Excel, I used the below method in Outlook's VBE to map the data I needed from each email into a csv that I could then save.
Sub read_drta()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.folders("my_email#address.com")
Set objFolder = objFolder.folders("Inbox")
Set objFolder = objFolder.folders("imports")
fpath = "C:\Users\Email_Tasker"
my_csv = fpath & "\data.csv"
Open my_csv For Output As #1
For Each Item In objFolder.Items
myLine = Item.Subject & "," & Item.SentOn & "," & Item.SenderEmailAddress & "," & Item.Attachments(1).FileName
Print #1, myLine
Next Item
Close #1
End Sub
The "Item" object contained everything in Outlook VBA, but oddly it still kept the same fields empty in Excel.
I have a bunch of data in excel that I need to write to txt, that I have to import in an other program. This software has a very specific format, and I have no idea how to create a code that will do it exactly as I need it.
Excel:
This is just an example, there are more columns and the actual version and the amount of lines also varies.
In the result text file this should look like this:
txt:
So it needs the id from line 2, followed by the lines number in brackets then equal sign and the associated name or date in this example.
Is there any way to do this?
You can use some looping through cells on the Excel sheet together with some VBA File Input/Output to achieve this. Below is some code that works correctly on the sample data provided, and should get you pointed in the right direction:
Sub sExportPersonData()
On Error GoTo E_Handle
Dim ws As Worksheet
Dim intFile As Integer
Dim strFile As String
Dim lngLastRow As Long
Dim lngLastCol As Long
Dim lngRowLoop As Long
Dim lngColLoop As Long
Dim strOutput As String
intFile = FreeFile
strFile = "J:\downloads\person.txt"
Open strFile For Output As intFile
Set ws = ThisWorkbook.Worksheets("Sheet1")
lngLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lngLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For lngRowLoop = 3 To lngLastRow
For lngColLoop = 2 To lngLastCol
strOutput = ws.Cells(2, lngColLoop) & "[" & ws.Cells(lngRowLoop, 1) & "]=" & ws.Cells(lngRowLoop, lngColLoop)
Print #intFile, strOutput
Next lngColLoop
Next lngRowLoop
sExit:
On Error Resume Next
Close #intFile
Set ws = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sExportPersonData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
I have been searching for awhile now trying to find a solution, i can find similar solutions but i cannot get any to work even with tweaks and amendments.
I have a master workbook called 'Master.xlsb' with 1 sheet called 'Summary'. I have a list of 189 files in one folder called 'EmailAttachments'.
Each individual file will have a different amount of rows so i would like to loop through all files and copy from range '"B7:B" & LastRow' and paste data below last row containing data in 'Master.xlsb' (Which will increase as data is pasted in).
Also, I would like to have the file name in column A starting from '"A7"' so i know which file the data is from.
Thanks in advance.
EDIT:
I managed to get the code working below:
Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer
Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")
Do While Len(Filename) > 0
Set wbk = Workbooks.Open(Path & Filename)
For i = 1 To 500
If Cells(i, 1).Value = intValueToFind Then
GoTo Skip
End If
Next i
LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
DataRowsSource = LastRowSource - 6
FileNameSource = Left(Filename, Len(Filename) - 5)
Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy
Workbooks("Master.xlsb").Activate
LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
ThisWorkbook.Sheets(1).Range("C1:E1").Copy
ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
wbk.Close True
Filename = Dir
Loop
End Sub
Here I found a nice code by user benmichae2. for looping through files in folder
Loop through files in a folder using VBA?
Reusing his/her code I would do something like this:
Option Explicit
Sub LoopThroughFiles()
Dim firstEmptyRow As Long
Dim attachmentFolder As String, StrFile As String, filenameCriteria As String
Dim attachmentWorkBook As Workbook
Dim copyRngToArray As Variant
'# Define folder with attachments and set file extension
attachmentFolder = "C:\temp"
filenameCriteria = "xlsx"
'set
StrFile = Dir(attachmentFolder & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
Set attachmentWorkBook = Workbooks.Open(StrFile)
With attachmentWorkBook.Worksheets(1)
'#Copy the first column to array starting from "A7" to End of column
copyRngToArray = .Range("A7:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
'#Thisworkbook is the file where this code is in actually your Master.xlsb file
With ThisWorkbook.Worksheets(1)
'#firsEmptyRow returns the first empty row in column B
firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
'#paste file name to Column A
.Range("A" & firstEmptyRow) = StrFile
'#paste data in column B
.Range("B" & firstEmptyRow).Resize(UBound(copyRngToArray)) = copyRngToArray
End With
Set attachmentWorkBook = Nothing
StrFile = Dir
Loop
End Sub
Paste this code in a module and check with some example excel files
Below code has worked for me (Change example path):
Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer
Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")
Do While Len(Filename) > 0
Set wbk = Workbooks.Open(Path & Filename)
For i = 1 To 500
If Cells(i, 1).Value = intValueToFind Then
GoTo Skip
End If
Next i
LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
DataRowsSource = LastRowSource - 6
FileNameSource = Left(Filename, Len(Filename) - 5)
Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy
Workbooks("Master.xlsb").Activate
LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
ThisWorkbook.Sheets(1).Range("C1:E1").Copy
ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
wbk.Close True
Filename = Dir
Loop
End Sub