To explain my title, basically i have a macro code which ill display in sec that is requesting number of days that need it to be exported from our shared mailbox. Now on a daily basis I have to change the number of days we need to export and is getting really frustrating. The following line is in question:
If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= 10 Then
That number 10 needs to change on a daily basis so i tried with active cell but no success as i get a runtime error 438.
So my question is: Is there a way that in a separated spreadsheet to input the number of days i need to export and that line in question can take the information from there and carry on with the code ?
Please see full code below.
Sub Accomplished()
Application.Run "Module5.OptimizeCode_Begin"
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name As String
Dim vItems As Outlook.Items
Dim vItem As Object
'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailBoxName = "Castle Donington Time and Attendance"
'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Accomplished" 'Sample "Inbox" or "Sent Items"
'To directly a Folder at a high level
'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)
'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder
Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If
'Read Through each Mail and export the details to Excel for Email Archival
ThisWorkbook.Sheets(3).Activate
Folder.Items.sort "Received"
'Insert Column Headers
ThisWorkbook.Sheets(3).Cells(1, 1) = "Sender"
ThisWorkbook.Sheets(3).Cells(1, 2) = "Subject"
ThisWorkbook.Sheets(3).Cells(1, 3) = "Date"
ThisWorkbook.Sheets(3).Cells(1, 4) = "Sent"
ThisWorkbook.Sheets(3).Cells(1, 5) = "EmailID"
ThisWorkbook.Sheets(3).Cells(1, 6) = "Categories"
ThisWorkbook.Sheets(3).Cells(1, 7) = "Parent"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"
'Export eMail Data from PST Folder
oRow = 1
Set vItems = Folder.Items
For iRow = 1 To vItems.Count
Set vItem = vItems.Item(iRow)
If vItem.Class = 43 Then
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= 10 Then
oRow = oRow + 1
ThisWorkbook.Sheets(3).Cells(oRow, 1).Select
ThisWorkbook.Sheets(3).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(3).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(3).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(3).Cells(oRow, 4) = Folder.Items.Item(iRow).SentOn
ThisWorkbook.Sheets(3).Cells(oRow, 5) = Folder.Items.Item(iRow).ConversationID
ThisWorkbook.Sheets(3).Cells(oRow, 6) = Folder.Items.Item(iRow).Categories
ThisWorkbook.Sheets(3).Cells(oRow, 7) = Folder.Items.Item(iRow).Parent
'ThisWorkbook.Sheets(3).Cells(oRow, 8) = Folder.Items.Item(iRow).Sent
'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
End If
End If
Next iRow
MsgBox "Extration Complete ^.^"
Set Folder = Nothing
Set sFolders = Nothing
' sheet3_copypaste Macro
Sheets("Sheet3").Select
ActiveWindow.SmallScroll Down:=-33
Range("A2:H3001").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Full List").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Format
Sheets("Full List").Select
Columns("D:E").Select
Selection.NumberFormat = "m/d/yyyy h:mm"
Range("D1").Select
' sort Macro
Range("D6").Select
ActiveWorkbook.Worksheets("Full List").sort.SortFields.Clear
ActiveWorkbook.Worksheets("Full List").sort.SortFields.Add Key:=Range("D6"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Full List").sort
.SetRange Range("A5:I4976")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("D1").Select
End_Lbl1:
Application.Run "Module5.OptimizeCode_End"
End Sub
Thank you for taking interest.
Any questions i'm happy to answer
Just for consistency sake with excel and macros a workbook is a full xlsm file that contains a collection of worksheets (individual tabs that you put data on). By a seperated spreadsheet I'm assuming a different workbook.
Here is some useful code for getting data from a spreadsheet.
The main function GetData at the bottom, instead of storing the data in a local cell you would just put it in a variable and use that in your "<" statement.
Sub GetDataDemo()
Dim FilePath$, Row&, Column&, Address$
'change constants & FilePath below to suit
'***************************************
Const FileName$ = "Book1.xls"
Const SheetName$ = "Sheet1"
Const NumRows& = 10
Const NumColumns& = 10
FilePath = ActiveWorkbook.Path & "\"
'***************************************
DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
For Row = 1 To NumRows
For Column = 1 To NumColumns
Address = Cells(Row, Column).Address
Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
Columns.AutoFit
Next Column
Next Row
ActiveWindow.DisplayZeros = False
End Sub
Private Function GetData(Path, File, Sheet, Address)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
Range(Address).Range("A1").Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function
If its from the same workbook you would just use something like
dim NUMDAYS as double
NUMDAYS = sheets("sheet2").range("A1").value to assign to a variable which would be used later in your macro.
If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= NUMDAYS Then
Related
I need to check if a list of files exist in a certain directory, based on cell values in Excel.
If some files are not found, a message box displays the names of the files that were not found.
I'm unclear if you want to see the files listed in the range that do not appear in the folder or if you want to see the files in the folder that are not in the range.
The following example lists the files in the range that are not in the folder.
I've set up a page for the example, so you may need to adjust your sheet to match, or adjust your code to fit your sheet. Be sure that the folder path you put in B1 has the trailing backslash.
Here's the code:
Sub files_in_folder()
Dim folder As String
Dim filename As String
Dim filenames As Range
Dim cell As Range
Dim s As Worksheet
Dim missing As New Collection
Dim message As String
Dim x As Integer
Set s = ActiveSheet
folder = s.Range("b1").Value
Set filenames = Range(s.Range("b2"), s.Range("b2").End(xlDown))
For Each cell In filenames
If Dir(folder + cell.Value) = "" Then missing.Add cell.Value
Next
If missing.Count = 0 Then
message = "All files were found in " & folder
Else
message = "The following files were not found in " & folder & vbNewLine
For x = 1 To missing.Count
message = message + " " + missing(x) & vbNewLine
Next
End If
MsgBox message
End Sub
Try this.
Sub TestListFilesInFolder()
' Open folder selection
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
If Right(pPath, 1) <> "\" Then
pPath = pPath & "\"
End If
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the file list
' add headers
ActiveSheet.Name = "ListOfFiles"
With Range("A2")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File Name:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("A3:F3").Font.Bold = True
Worksheets("ListOfFiles").Range("A1").Value = pPath
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
' list all files included subfolders
Range("A3").Select
Lastrow = Range("A1048576").End(xlUp).Row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
"B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ListOfFiles").Sort
.SetRange Range("A3:F" & Lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
NextCode:
MsgBox "No files Selected!!"
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A1048576").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path & FileItem.Name
Cells(r, 2).Formula = (FileItem.Size / 1048576)
Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
' use file methods (not proper in this example)
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:F").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Result:
I am trying to generate CSV files from a set of records from Excel.
Column A is the file name and the rest of the columns are the data to write to the the file.
As of now, I am using WriteLine, but it doesn't work as expected:
As you can see, I don't get the expected output. How do I get the expected output?
Private Sub ommandButton1_Click()
Dim Path As String
Dim Folder As String
Dim Answer As VbMsgBoxResult
Path = "C:\Access Permissions\Users"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
'-------------Create Folder -----------------------
MkDir ("C:\Access Permissions")
MkDir ("C:\Access Permissions\Roles")
MkDir ("C:\Access Permissions\Users")
Else
Set rngSource = Range("A4", Range("A" & Rows.Count).End(xlUp))
rngSource.Copy Range("AA1")
Range("AA:AA").RemoveDuplicates Columns:=1, Header:=xlNo
Set rngUnique = Range("AA1", Range("AA" & Rows.Count).End(xlUp))
Set lr = Cells(rngSource.Rows.Count, rngSource.Column)
Set fso = CreateObject("Scripting.FileSystemObject")
For Each cell In rngUnique
n = Application.CountIf(rngSource, cell.Value)
Set C = rngSource.Find(cell.Value, lookat:=xlWhole, after:=lr)
Set oFile = fso.CreateTextFile("C:\Access Permissions\Users\" & cell.Value & "-Users.csv")
For i = 1 To n
oFile.WriteLine C.Offset(0, 1).Value
oFile.WriteLine C.Offset(0, 2).Value
oFile.WriteLine C.Offset(0, 3).Value
oFile.WriteLine C.Offset(0, 4).Value
oFile.WriteLine C.Offset(0, 6).Value
oFile.WriteLine C.Offset(0, 7).Value
Set C = rngSource.FindNext(C)
Next i
Next cell
rngUnique.ClearContents
MsgBox "Individual Users.csv files got generated" & vbCrLf & " " & vbCrLf & "Path - C:\Access Permissions\Groups "
End If
End Sub
Updated Image:
Let me re-phrase my questions.
Updated Image Enclosed.
Using the Data Set [Updated Image point 1], It creates unique CSV files based on column A.
File got saved at the path given.
As of now the row data associated with each file name got written in the files but in a new line manner.
As expected, how the output can be written in Columns.[ Updated Image Point 4]
Given code is working without any error.
5.1. I just need to click twice if the Path folder does not exist.
5.2. at first click, it creates the Folder at the given path.
5.3. at Second click it generates the unique files, with its records.
If you can please guide me on how the records can be written in columns [ Updated Image Point 4 ], expected output.
Download File
I assume your data does not contain any semicolons.
You are writing each field on a line by itself. Instead, join the fields on a single line:
oFile.WriteLine C.Offset(0, 1).Value & ";" & _
C.Offset(0, 2).Value & ";" & _
C.Offset(0, 3).Value & ";" & _
C.Offset(0, 4).Value & ";" & _
C.Offset(0, 6).Value & ";" & _
C.Offset(0, 7).Value
There are other bugs in your example; it should not work as far as I can see. For example, you keep opening the same file with CreateTextFile. You should only create a file once, not every time you write to it. According to the documentation, you should get an error on your second try, see CreateTextFile method. The reason you don't get an error is probably because you never close the file. You should close the files you create.
I would use this approach instead:
' Collect the data for each file into a dictionary.
' The cells in the table must not contain semicolons.
Sub Doit()
Dim Sht As Worksheet
Dim Rng As Range
Dim LastRowNum As Long, LastColNum As Long
Dim Lst As Variant, Hdr As Variant, Elem As Variant
Dim Idx As Long, Idx2 As Long
Dim Dct As Object
Dim HdrTxt, Txt As String, Sep As String
Dim Filename As String
Set Sht = ActiveSheet
' Get the last row in column 1
Set Rng = Sht.Cells(Sht.Rows.Count, 1).End(xlUp)
LastRowNum = Rng.Row
' Get the last column in row 3
Set Rng = Sht.Cells(3, Sht.Columns.Count).End(xlToLeft)
LastColNum = Rng.Column
' Get the headers in row 3
Set Rng = Sht.Range(Sht.Cells(3, 1), Sht.Cells(3, LastColNum))
Hdr = Rng
' Create a semicolon seprated line for the headers
HdrTxt = ""
Sep = ""
For Idx = LBound(Hdr, 2) To UBound(Hdr, 2)
HdrTxt = HdrTxt & Sep & Hdr(1, Idx)
Sep = ";"
Next Idx
HdrTxt = HdrTxt & vbNewLine
' Get the data from row 4 and down
Set Rng = Sht.Range(Sht.Cells(4, 1), Sht.Cells(LastRowNum, LastColNum))
Lst = Rng
' Store the data for each file in a dicitonary
Set Dct = CreateObject("Scripting.Dictionary")
For Idx = LBound(Lst) To UBound(Lst)
Filename = Lst(Idx, 1)
' Create a semicolon seprated line
Txt = ""
Sep = ""
For Idx2 = LBound(Lst, 2) To UBound(Lst, 2)
Txt = Txt & Sep & Lst(Idx, Idx2)
Sep = ";"
Next Idx2
Txt = Txt & vbNewLine
' Add the line to the dictionary
If Dct.Exists(Filename) Then
Dct(Filename) = Dct(Filename) & Txt
Else
Dct(Filename) = HdrTxt & Txt
End If
Next Idx
' Output data for each file to the immdiate window
For Each Elem In Dct
' Change this to open the file and write the contents
Debug.Print "---- Filename: " & Elem
Debug.Print Dct(Elem)
Next Elem
End Sub
The example makes sure you only create the files once:
Change the last loop For Each Elem In Dct that prints the data to the immediate window, to create a file instead. Use the Write method instead of the WriteLine method, as the data already contains the line-breaks. And remember to Close the files.
I think this is what you want.
Sub Copy_To_Workbooks()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim MyPath As String
Dim foldername As String
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:B" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new workbook"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Set the file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".txt": FileFormatNum = -4143
Else
'You use Excel 2007-2010
If ActiveWorkbook.FileFormat = 56 Then
FileExtStr = ".txt": FileFormatNum = 56
Else
FileExtStr = ".txt": FileFormatNum = 51
End If
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Delete the sheet RDBLogSheet if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("RDBLogSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
ws2.Name = "RDBLogSheet"
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = "C:\Users\ryans\OneDrive\Desktop\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A3"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A4:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Copy/paste the visible data to the new workbook
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
On Error Resume Next
ChDir MyPath
ActiveWorkbook.SaveAs Filename:= _
foldername & cell.Value & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
If Err.Number > 0 Then
Err.Clear
ErrNum = ErrNum + 1
WSNew.Parent.SaveAs foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
.Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
.Cells(cell.Row, "A").Interior.Color = vbRed
Else
.Cells(cell.Row, "B").Formula = _
"=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
End If
WSNew.Parent.Close False
On Error GoTo 0
End If
'Show all the data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
.Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
.Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
.Cells(3, "A").Value = "Unique Values"
.Cells(3, "B").Value = "Full Path and File name"
.Cells(3, "A").Font.Bold = True
.Cells(3, "B").Font.Bold = True
.Columns("A:B").AutoFit
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
ws2.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Before:
After:
I have an excel macro that can separate and save files per column. My problem is that I cannot make it work with large number of rows (60,000).
What should I change in my VBA code below to make it work?
Dim MyFile, NewFile As Variant
Dim sort_data As String
Dim last_row, tfiles, start_row, ktr As Integer
'Capture errors
On Error GoTo ErrorHandler
'Check for complete data
If (Separate.file_open.Value = False And Separate.Filename _
= "") Or Separate.first = "" Or Separate.last = "" Or _
Separate.sort = "" Or Separate.left_column = "" Or _
Separate.right = "" Then
MsgBox "Insufficient data.", 16, "Warning!"
Exit Sub
End If
'Turn application alerts off
Application.DisplayAlerts = False
'Open filename if necessary
If Separate.file_open.Value = False Then
Workbooks.Open Separate.Filename
End If
'Get current workbook name
MyFile = left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) _
- 4)
'Get last row of data
For last_row = Separate.last + 1 To 1048576
If Range(Separate.sort & last_row).Value = "" Then
Exit For
End If
Next last_row
'Sort data
Range(Separate.left_column & Separate.last, Separate.right & last_row).Select
Selection.sort Key1:=Range(Separate.sort & Separate.last + 1), Order1:=xlAscending, Header:=True, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
The problem is due to:
Dim last_row, tfiles, start_row, ktr As Integer
Integer mentioned in the script having a max number 32,767. You can use Long instead of Integer.
Dim last_row, tfiles, start_row, ktr As Long
I am working on a big project and the ability to change the code stopped at this point. So help is needed please.
The main folders have subfolders and MSR files inside which are related to eachother with the naming.We have to input this main folder path into D4 on our excel file.
The MSR have all the info related to every image. Image folders have all the images inside and we need to sort the all into subfolders.
We already have a macro that retrieves a list on which images are correlated to the correct position. ( see third image)
What we want do now is creating subfolders into the main folder that corresponds to the "*test" in this case and in this new folder there should be subfolders created based on how many unique places there are. In this case it would result in 18 subfolder. The combination of Column D and E are the unique places (first 2 examples = 13200-9496 and 13213-9506). All the image files that corrospond to this place should be put in the new subfolder.
I hope this is somewhat clear?
Main folder overview
Sub folder overview
Output data
Code:
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WBMacro As Workbook
Set WBMacro = ActiveWorkbook
Dim FoName As Range
Set FoName = WBMacro.Sheets("Instructions").Range("B4")
FolderName = FoName
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
FName = Dir(FolderName & "*.msr")
'loop through the files
Do While Len(FName)
Dim WBMSR As Workbook
Set WBMSR = Workbooks.Open(FolderName & FName)
With WBMSR
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
'Create new tab to copy data of interest in
Dim WsMSR As Worksheet
Set WsMSR = WBMSR.ActiveSheet
WsMSR.Name = "MSRData"
.Worksheets.Add
Dim wsPictData As Worksheet
Set wsPictData = WBMSR.Sheets("Sheet1")
wsPictData.Name = "PictureInfo"
'Define where to copy data to
Dim RngPictName As Range
Dim RngX As Range
Dim RngY As Range
Set RngPictName = wsPictData.Range("A2")
Set RngXY = wsPictData.Range("B2")
Set RngChipCoX = wsPictData.Range("D2")
Set RngChipCoY = wsPictData.Range("E2")
RngPictName.Offset(-1, 0) = "PictName"
RngXY.Offset(-1, 0) = "DieX,DieY"
RngChipCoX.Offset(-1, 0) = "ChipCoX"
RngChipCoY.Offset(-1, 0) = "ChipCoY"
'Find PictureName
Dim RngPictStart As Range
Dim RngPictStop As Range
Dim RngPict As Range
Dim strImage As String
strImage = "&mp_image_name"
Dim strChipNr As String
strChipNr = "Chip_number"
Dim strChipCo As String
strChipCo = "Chip_coordinate"
With WsMSR.Range("B:B")
Set image = .Find(strImage, lookat:=xlPart, LookIn:=xlValues)
If Not image Is Nothing Then
FirstAddress = image.Address
Do
Set pict = image.Offset(0, 2)
pict.Copy
If RngPictName = "" Then
RngPictName.PasteSpecial
Else
RngPictName.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
For i = 1 To 15
'Do
If image.Offset(i, 1).Value = strChipNr Then
Set XY = image.Offset(i, 2)
XY.Copy
If RngXY = "" Then
RngXY.PasteSpecial
Else
RngXY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
End If
If image.Offset(i, 1).Value = strChipCo Then
Set ChipX = image.Offset(i, 2)
ChipX.Copy
If RngChipCoX = "" Then
RngChipCoX.PasteSpecial
Else
RngChipCoX.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
Set ChipY = image.Offset(i, 4)
ChipY.Copy
If RngChipCoY = "" Then
RngChipCoY.PasteSpecial
Else
RngChipCoY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
End If
Next
Set image = .FindNext(image)
If image Is Nothing Then
GoTo DoneFinding1
End If
Loop While image.Address <> FirstAddress
End If
End With
DoneFinding1:
End With
' change wsPictData Column B with (x,Y) to 2 columns (B = X, C = Y)
With wsPictData
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
End With
WsMSR.Delete
Dim WBMSRFileName As String
WBMSRFileName = Left(WBMSR.Name, Len(WBMSR.Name) - 4)
Dim relativePath As String
relativePath = WBMSR.Path
WBMSR.SaveAs Filename:=relativePath & "\" & "Pictures_" & WBMSRFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
WBMSR.Close (False)
' go to the next file in the folder
FName = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("all Files in folder" & relativePath & " are analyzed")
This is a schema to clarify the folder tree. Picture test is the main folder (in this example, name is always different). The grey area on the bottom is wat the macro needs to make. Inside Mainfolder, create for every "test" a new folder with appendix "filtered" and in every folder new folders with the location which hold all the images that were taken on that location.
folder tree
msr file example
This scans the MAIN_FOLDER for excel files starting with Pictures_, opens them and scans down the rows building the destination folder names from columns A, D and E. I put message boxes at each stage so if you single step through you can study how it works. It will create sub-folders if you confirm the action but the actual copy method at the end is commented out. See FileSystemObject for more details.
Sub imagemove()
Const MAIN_FOLDER = "c:\temp\msr\"
Dim FileName As String, wb As Workbook, ws As Worksheet
Dim count As Long, iLastRow As Long, iRow As Long
Dim sPictureFolder As String, sCopyFolder As String
Dim sCopySubFolder As String, msg As String
Dim sPictureName As String, sChipCoX As String, sChipCoY As String
Dim sSrc As String, sDest As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FileName = Dir(MAIN_FOLDER & "Pictures_*.xlsx")
Do While Len(FileName) > 0
' determine picture folder from filename
sPictureFolder = MAIN_FOLDER & Mid(FileName, 10, Len(FileName) - 14)
sCopyFolder = sPictureFolder & "-Filtered"
Debug.Print sPictureFolder, sCopyFolder
' check if folder exists
If FSO.FolderExists(sCopyFolder) = False Then
msg = sCopyFolder & " does not exist, do you want to create it"
If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
FSO.CreateFolder sCopyFolder
Else
Exit Sub
End If
End If
' scan down msr file
Set wb = Workbooks.Open(MAIN_FOLDER & FileName, False, True)
Set ws = wb.Sheets("PictureInfo")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
'Debug.Print FileName, iLastRow
For iRow = 2 To iLastRow
sPictureName = ws.Cells(iRow, 1) ' A
sChipCoX = ws.Cells(iRow, 4) ' D
sChipCoY = ws.Cells(iRow, 5) ' E
' ignore jpeg images
If Right(sPictureName, 4) = "jpeg" Then GoTo skip
sCopySubFolder = sCopyFolder & "\" & sChipCoX & "-" & sChipCoY
' check if sub folder exists
If FSO.FolderExists(sCopySubFolder) = False Then
msg = sCopySubFolder & " does not exist, do you want to create it"
If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
FSO.CreateFolder sCopySubFolder
Else
Exit Sub
End If
End If
' move locations
sSrc = sPictureFolder & "\" & sPictureName
sDest = sCopySubFolder & "\" & sPictureName
' check file exists
If FSO.FileExists(sSrc) = True Then
MsgBox "Copy from " & sSrc & " to " & sDest
'FSO.CopyFile sSrc, sDest
Else
MsgBox sSrc & " does not exist", vbCritical, "File does not exist"
'test FSO.CreateTextFile sDest
End If
Debug.Print "Copy", sSrc, "to", sDest
skip:
Next
count = count + 1
FileName = Dir
Loop
MsgBox count & " Pictures_* files scanned in " & MAIN_FOLDER, vbInformation
End Sub
Ok, I have to answer my question... I deleted all the jpeg files from the Pictures file so these images are not copied so I created another loop. I first had it inside your loop but then it would create an extra extra empty folder. But now I`m afraid that I slowed down the macro by a lot? Is it better to do it inside your loop and then delete the "-" folder in the end?
Set wb = Workbooks.Open(MAIN_FOLDER & "\" & FileName, False, True)
Set ws = wb.Sheets("PictureInfo")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
'Debug.Print FileName, iLastRow
For iRow = 2 To sLastrow
If Right(ws.Cells(iRow, 1).Text, 4) = "jpeg" Then ws.Cells(iRow, 1).EntireRow.Delete
Next
For iRow = 2 To iLastRow
sPictureName = ws.Cells(iRow, 1) ' A
sChipCoX = ws.Cells(iRow, 4) ' D
sChipCoY = ws.Cells(iRow, 5) ' E
```
I have a set of Excel spreadsheets to summarise. My sheets are numbered:
xxx-yy-zzzz; xxx-yy-zzz+1; etc.
I would like a reporting spreadsheet to retrieve information each time it is opened. I don't mind doing it with VBA or with formulae.
I've the macro below. I need to auto increment until it runs out of spreadsheets. All the files will be in the same folder, this file can be in any folder.
Sub Macro1()
'
' Macro1 Macro
' autopop
'
'
Range("C4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R4C5"
Range("D4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R5C3"
Range("E4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Order'!R27C9"
Range("F4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R8C9"
End Sub
Siddharth's method above worked very well for when we were using very simple file names, but it got a lot harder when there were additions made to the filename... So i did some surfing and found a basis of a "list all files and put them in a worksheet" and using some of the code from Siddharth's answer above (thank you very much Mr. Siddharth) and the example i found online here http://alanmurray.blogspot.com/2013/08/excel-vba-list-all-excel-files-in-folder.html , i have finalised my code, and my little VBA app now does what i want - it opens a folder and goes through and pulls out particular cells and creates a summary report in seconds -> will save me hours of tedious work...
Code:
Sub ImportFileList()
Dim MyFolder As String 'Store the folder selected by the using
Dim FiletoList As String 'store the name of the file ready for listing
Dim NextRow As Long 'Store the row to write the filename to
On Error Resume Next
Application.ScreenUpdating = False
'Display the folder picker dialog box for user selection of directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
'Dir finds the first Excel workbook in the folder
FiletoList = Dir(MyFolder & "*.xls")
Range("A1").Value = "Filename"
Range("B1").Value = "Purchase Order Number"
Range("C1").Value = "Vendor"
Range("D1").Value = "Date of PO"
Range("E1").Value = "Currency"
Range("F1").Value = "Subtotal"
Range("G1").Value = "VAT"
Range("H1").Value = "Total"
Range("A1:H1").Font.Bold = True
'Find the next empty row in the list
NextRow = Application.CountA(Range("A:A")) + 1
NextRow = NextRow + 1 ' skip a line
'Do whilst the dir function returns an Excel workbook
Do While FiletoList <> ""
Cells(NextRow, 1).Value = FiletoList 'Write the filename into the next available cell
Cells(NextRow, 2).Formula = "='[" & FiletoList & "]Cover'!R4C4" ' Cover is the excel sheet name
Cells(NextRow, 3).Formula = "='[" & FiletoList & "]Cover'!R6C3"
Cells(NextRow, 4).Formula = "='[" & FiletoList & "]Cover'!R4C7"
Cells(NextRow, 5).Formula = "='[" & FiletoList & "]Cover'!R21C4"
Cells(NextRow, 6).Formula = "='[" & FiletoList & "]Cover'!R19C5"
Cells(NextRow, 7).Formula = "='[" & FiletoList & "]Cover'!R20C5"
Cells(NextRow, 8).Formula = "='[" & FiletoList & "]Cover'!R21C5"
NextRow = NextRow + 1 'Move to next row
FiletoList = Dir 'Dir returns the next Excel workbook in the folder
Loop
Application.ScreenUpdating = True
End Sub
Is this what you are trying? (UNTESTED)
'~~> Change this to the directory which has .xlsx files
Const sDir = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim i As Long, num As Long, Calcmode As Long
Dim FilesCount As Long, startNum As Long
On Error GoTo Whoa
Set ws = ThisWorkbook.Sheets("Sheet1")
With Application
.ScreenUpdating = False
Calcmode = .Calculation
.Calculation = xlCalculationManual
End With
'~~> Get the number of files in that directory
FilesCount = getFileCount(sDir)
startNum = 1
If FilesCount <> 0 Then
With ws
For i = 4 To (FilesCount + 3)
num = Format(startNum, "000")
.Range("C" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R4C5"
.Range("D" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R5C3"
.Range("E" & i).Formula = "='[413-05-" & num & ".xlsx]Order'!R27C9"
.Range("F" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R8C9"
startNum = startNum + 1
Next i
End With
End If
LetsContinue:
With Application
.ScreenUpdating = True
.Calculation = Calcmode
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Function getFileCount(s As String) As Long
Dim Path As String, Filename As String
Dim Count As Long
Path = s & "*.xlsx"
Filename = Dir(Path)
Do While Filename <> ""
Count = Count + 1
Filename = Dir()
Loop
getFileCount = Count
End Function