I have the following VBA code meant to loop through a given folder and compile all files of a certain type into one single worksheet.
Sub cons_data()
Dim Master As Workbook
Dim sourceBook As Workbook
Dim sourceData As Worksheet
Dim CurrentFileName As String
Dim myPath As String
Dim LastRow As Long
Dim lRow As Long
Dim i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'The folder containing the files to be recap'd
myPath = "path"
'Finds the name of the first file of type .xls in the current directory
CurrentFileName = Dir(myPath & "\*.txt*")
'Create a workbook for the recap report
Set Master = ThisWorkbook
For i = 1 To Master.Worksheets.Count
With Master.Worksheets(i)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If lRow > 1 Then .Rows("2:" & lRow).ClearContents
End With
Next i
Do
Workbooks.Open (myPath & "\" & CurrentFileName)
Set sourceBook = Workbooks(CurrentFileName)
For i = 1 To sourceBook.Worksheets.Count
Set sourceData = sourceBook.Worksheets(i)
With sourceData
LastRow = Master.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Rows("2:" & lRow).Copy Master.Worksheets("Sheet1").Rows(LastRow + 1)
End With
Next i
sourceBook.Close
'Calling DIR w/o argument finds the next .txt file within the current directory.
CurrentFileName = Dir()
Loop While CurrentFileName <> ""
MsgBox "Done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This script works fine on certain file types, but for some reason when running it on a list of text files with a standard format (some of which are duplicates) it stops and presents the most recent entry it was working on in a separate Excel sheet. Is there any obvious reason looking at the code that this might be happening?
You need to kill old processes and discharge resources memory by adding after :
Set sourceBook = nothing
After
sourceBook.close
Hope this can help
Related
I have 4 macros running one after the other:
1st - looks for the latest (newest) file in the source file location: In here I have a problem, because if there is no file at the location (C:\Source File) then, the file that is currently opened (main file) is formatted in the way that only the source file should be. I don't need message box and I don't want this (Main) file to be formatted if there is no source data file in the location.
'1
Option Explicit
Sub OpenLatestFile()
Application.ScreenUpdating = False
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
MyPath = "C:\Source File\"
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "*.csv", vbNormal)
If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
Do While Len(MyFile) > 0
LMD = FileDateTime(MyPath & MyFile)
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
Workbooks.Open MyPath & LatestFile
Application.ScreenUpdating = True
End Sub
2nd Macro: Column Removals
'2
Sub RemoveCols()
Application.ScreenUpdating = False
Alfa1 = ActiveWorkbook.Name
Range("X:AA,FA:I").Delete
Application.ScreenUpdating = True
End Sub
3rd: Row Removal
'3
Sub RemoveXYZ()
Application.ScreenUpdating = False
Dim lLRow As Long
With Sheets(1)
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("C:C").AutoFilter Field:=1, Criteria1:="XYZ"
.Range("C2:C" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlShiftUp
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
4th: Copy formatted data from the source file into the Main file (which has Macros in it)
'4
Option Explicit
Sub TransferData()
Application.ScreenUpdating = False
Dim Last_Row1 As Long, Last_Row2 As Long
Dim WB1 As Workbook, WB2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set WB1 = ActiveWorkbook
Set ws1 = WB1.Sheets(1)
Set WB2 = Workbooks("MainFile.xlsm")
Set ws2 = WB2.Sheets("Master")
Last_Row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("A2:Z" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
WB2.Save
Application.Quit
Application.DisplayAlerts = False
WB1.SaveChanges = False
WB2.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Can you please advise how to maximize the efficiency of the above codes and make sure that the main file is not being formatted if there's no data in the "source file folder"?
Moreover, the 1st macro is looking for the latest file (I would like to make sure that it doesn't pick up the file from the previous day) - any idea how to add a command "do not open source data if date is "minus 1 from today's date"?
Thanks
West
I combined all 4 macros and cleaned up a few pieces. The biggest change is setting your workbooks and worksheets earlier so the referencing was easier.
Is macro 2 affecting the source file or the master file? If each macro runs one after another, then it seems it would be the source file, which is what I did in the code below. If that is wrong you will need to move .Range("X:AA,FA:I").Delete out of the With WS1 block and change it to WS2.Range("X:AA,FA:I").Delete.
As you can see, the first part of the code is almost identical. When MyFile is first assigned, it will be a zero-length string if there are no .csv files in the directory. The code then tests whether MyFile is in fact a zero-length string: If Len(MyFile) > 0 Then. So if no .csv files exist in MyPath, the If statement is executed and runs Exit Sub, which stops execution of the procedure. Because the code is all in one sub, the formatting code will not run if the folder is empty.
So to make this work you will need to stop the calls on macros 2-4 and replace macro 1 with the code below.
Option Explicit
Sub ProcessLatestFile()
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
Dim lLRow As Long
Dim Last_Row1 As Long, Last_Row2 As Long
Dim WB1 As Workbook, WB2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Application.ScreenUpdating = False
'Check for file
MyPath = "C:\Source File\"
MyFile = Dir(MyPath & "*.csv", vbNormal)
If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
Do While Len(MyFile) > 0
LMD = FileDateTime(MyPath & MyFile)
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
'Open Source File
Set WB1 = Workbooks.Open(MyPath & LatestFile)
Set ws1 = WB1.Sheets(1)
Set WB2 = Workbooks("MainFile.xlsm")
Set ws2 = WB2.Sheets("Master")
'Format Source File
With WS1
.Range("X:AA,FA:I").Delete
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("C:C").AutoFilter Field:=1, Criteria1:="XYZ"
.Range("C1:C" & lLRow).Offset(1,0).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlShiftUp
.AutoFilterMode = False
End With
'Copy data
Last_Row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("A2:Z" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
'Clean Up
Application.DisplayAlerts = False
WB1.SaveChanges = False
WB2.Save
Application.DisplayAlerts = True
Application.Quit
Application.ScreenUpdating = True
End Sub
I am completely newbie to VBA however I was given a task to complete using VBA. How do I create a code which copies the data of multiple worksheets from different workbooks and pastes them into another workbook (master data file) by adding exactly the same number of separate worksheets to this master data file? That is, I would like to display all of those worksheets being copied over to separate worksheets in the master data file.
I have managed to pull off a code which copies the data over and pastes it into one single worksheet but I am struggling to get them copied over one by one to separate worksheets.
Your help is much appreciated.
Sub datatransfer()
Dim FolderPath, FilePath, Filename, targetfile As String
Dim wb1, wb2 As Workbook
Dim i, mycount As Long
targetfile = "Left the location out on purpose"
FolderPath = " Left the location out on purpose "
FilePath = FolderPath & "*.xls*"
Filename = Dir(FilePath)
Dim lastrow, lastcolumn As Long
Do While Filename < ""
mycount = mycount + 1
Filename = Dir()
Set wb1 = Workbooks.Open(FolderPath & Filename)
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy
Application.DisplayAlerts = False
Set wb2 = Workbooks.Open(targetfile)
Worksheets.Add Before:=Sheet1, Count:=2
For i = 1 To mycount
With Worksheets(i)
ActiveSheet.Paste Destination:=.Range(Cells(2, 2), Cells(2, lastcolumn))
End With
Next i
ActiveWorkbook.Close SaveChanges:=True
Filename = Dir
Loop
End Sub
See the code below. I made several notes where I modified the code a bit to ensure it works with hitches going forward.
Sub datatransfer()
'have to specify type for all variables, techinically it still works the way you did, but you are setting unncessary memory
Dim FolderPath As String, FilePath As String, Filename As String, targetfile As String
Dim wb1 As Workbook, wb2 As Workbook
targetfile = "Left the location out on purpose"
FolderPath = " Left the location out on purpose "
FilePath = FolderPath & "*.xls*"
Set wb2 = Workbooks.Open(targetfile) 'only need to open this once and leave open until execution is finished
Filename = Dir(FilePath)
Do While Filename <> "" ' need "<>" to say not equal to nothing
wb2.Worksheets.Add After:=wb2.Worksheets(wb2.Worksheets.Count) 'add new sheet to paste data in target book
Set wb1 = Workbooks.Open(FolderPath & Filename)
Dim lastrow As Long, lastcolumn As Long
With wb1.Worksheets(1) 'best to qualify all objects and work directly with them
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
'pretty sure you want to add this A1, since it's a new blank sheet
.Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy _
Destination:=wb2.Worksheets(wb2.Worksheets.Count).Range("A1")
End With
wb1.Close False 'assume no need to save changes to workbook you copied data from
Filename = Dir
Loop
wb2.Close True 'no close and save master file
End Sub
I wrote a macro as an AddIn so that it is available in any of the workbooks I open. This macro will automatically save an Excel file as a CSV file. When I open a new workbook (newwb.xlsx) and apply this AddIn, I want my code to automatically find the path where I saved this newwb.xlsx and save it in the same location.
I found online that Application.ActiveWorkbook.Path can be used to locate path itself and Application.ActiveWorkbook.FullName for the path with the workbook name. However, it only returns the path name of the AddIn file and not the path name of newwb.xlsx.
How do I get the file path of the new workbook file?
Here is my code:
'Declare the data type of the variables
Dim wks As Worksheet
Dim lastCol As Integer
Dim lastRow As Long
Dim iCol As Integer
Dim iRow As Long
Dim sFilename As String
Dim cellValue As String
Dim MyTextFile
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location of the csv file to a variable
sFilename = Application.ActiveWorkbook.FullName & "\newwb.csv"
'Within the current active worksheet, identify the last interested row and column of data
'Any values such as 'a', '1' or '%' are considered as values. Spaces (Spacebars) are not considered as values.
With wks
With .Cells(1, 1).CurrentRegion
lastCol = .Columns.Count
lastRow = .Rows.Count
End With
'Delete extra rows with blank spaces
For iRow = 1 To lastRow
For iCol = 1 To lastCol
cellValue = wks.Cells(iRow, iCol)
Next iCol
If Trim(cellValue) = "" Then
wks.Cells(iRow, iCol).EntireRow.Clear
wks.Cells(iRow, iCol).EntireColumn.Clear
End If
Next iRow
'Delete extra rows and columns with formats
.Cells(lastRow + 1, 1).Resize(Rows.Count - lastRow, 1).EntireRow.Clear
.Cells(1, lastCol + 1).Resize(1, Columns.Count - lastCol).EntireColumn.Clear
.UsedRange.Select
End With
'Save as .CSV file in the specific location stated earlier
'If there are errors in the code when Users presses 'No' for the conversion, set wks to nothing and end the process
On Error GoTo err_handler
wks.SaveAs Filename:=sFilename, FileFormat:=xlCSV
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
'Notify users that the .CSV file has been saved
MsgBox sFilename & " saved"
'Opens the CSV file in a specifc location in Notepad
MyTextFile = Shell("C:\Windows\notepad.exe ActiveWorkbook.Path & /S /K ""\newwb.csv""", vbNormalFocus)
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub
Edit:
Application.ActiveWorkbook.Path works at the line:
sFilename = Application.ActiveWorkbook.Path & "\newwb.csv"
but there is an error saying that the system cannot find the path in this line:
MyTextFile = Shell("C:\Windows\notepad.exe Application.ActiveWorkbook.Path & /S /K ""\newwb.csv""", vbNormalFocus)
ActiveWorknook.Fullname works correctly for me when used from an XLA.
Note that your code
sFilename = Application.ActiveWorkbook.FullName & "\newwb.csv"
does not use just the path to the active workbook but the path and name of the active workbook appended with \newwb.csv
I have found the way to run the code smoothly, in courtesy of How do you run a .exe with parameters using vba's shell()? . Hope this will help anyone in need, and I would like to appreciate my gratitude to those who have tried to help. Thanks!!
Final Code:
Option Explicit
Sub CreateCSV()
'Declare the data type of the variables
Dim wks As Worksheet
Dim lastCol As Integer
Dim lastRow As Long
Dim iCol As Integer
Dim iRow As Long
Dim sFilename As String
Dim cellValue As String
Dim MyTextFile
Dim strProgramName As String
'Set wks to the current active worksheet
Set wks = ActiveWorkbook.ActiveSheet
'Set the location of the csv file to a variable
sFilename = Application.ActiveWorkbook.Path & "\testing.csv"
'Within the current active worksheet, identify the last interested row and column of data
'Any values such as 'a', '1' or '%' are considered as values. Spaces (Spacebars) are not considered as values.
With wks
With .Cells(1, 1).CurrentRegion
lastCol = .Columns.Count
lastRow = .Rows.Count
End With
'Delete extra rows with blank spaces
For iRow = 1 To lastRow
For iCol = 1 To lastCol
cellValue = wks.Cells(iRow, iCol)
Next iCol
If Trim(cellValue) = "" Then
wks.Cells(iRow, iCol).EntireRow.Clear
wks.Cells(iRow, iCol).EntireColumn.Clear
End If
Next iRow
'Delete extra rows and columns with formats
.Cells(lastRow + 1, 1).Resize(Rows.Count - lastRow, 1).EntireRow.Clear
.Cells(1, lastCol + 1).Resize(1, Columns.Count - lastCol).EntireColumn.Clear
.UsedRange.Select
End With
'Save as .CSV file in the specific location stated earlier
'If there are errors in the code when Users presses 'No' for the conversion, set wks to nothing and end the process
On Error GoTo err_handler
wks.SaveAs Filename:=sFilename, FileFormat:=xlCSV
'System to/not display alerts to notify Users that they are replacing an existing file.
Application.DisplayAlerts = True
'Notify users that the .CSV file has been saved
MsgBox sFilename & " saved"
'Opens the CSV file in a specifc location in Notepad
strProgramName = "C:\Windows\notepad.exe"
MyTextFile = Shell("""" & strProgramName & """ """ & sFilename & """", vbNormalFocus)
err_handler:
'Set Wks to its default value
Set wks = Nothing
End Sub
I have used the following script to copy multiple workbooks (sheets 1 only) into one master workbook. But, as multiple files are saved in the source folder each day, I now have hundreds of files in my source folder and would like to refine the folders that I copy to the master file.
I there a way to restrict the folders by using a date that appears in the file names. File path is ALWAYS the same format ...
5 alpha characters __ the date the file was saved (dateformat: ddmmyy) __ Julian Date
e.g.
NOCSR__060715__162959
SBITT__060715__153902
LVECI__030715__091316
Can I use the date in the file path and allow the user the input 'from' and 'to' dates? The master workbook would then only pull data from files that were saved within the date range.
Sub MergeFilesWithoutSpaces()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer
ThisWB = ActiveWorkbook.Name
path = "K:\UKSW CS Bom Expections\CS_BOM_Corrections\Archive"
RowofCopySheet = 2
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
Set Dest = shtDest.Range("A" & shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1)
CopyRng.Copy
Dest.PasteSpecial xlPasteFormats
Dest.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'Clear Clipboard
Wkb.Close False
End If
Filename = Dir()
Loop
Thanks, SMORF
Im not sure you need to save the date in the file name. You can read the date created property of a file with this function...
Sub GetDateCreated()
Dim oFS As Object
Dim strFilename As String
'Put your filename here
strFilename = "c:\excel stuff\commandbar info.xls"
'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")
MsgBox strFilename & " was created on " & oFS.GetFile(strFilename).DateCreated
Set oFS = Nothing
End Sub
(pinched from here http://www.mrexcel.com/forum/excel-questions/73458-read-external-file-properties-date-created-using-visual-basic-applications.html)
Then you could write a function that takes a start date and end date and returns a list of filenames...
I have written a macro for my boss to open a particular folder which contain approximately 100 workbooks having same format and collate all the data from those workbooks into the host excel where the macro is. Now the problem is, it works absolutely fine on my PC but when I had run it on the boss' PC it runs without executing the code(no data is collated) and displays the success message in the end in a second. Any help is appreciated. Here is the macro code
Sub collate()
Application.ScreenUpdating = False
Dim folderDialog As FileDialog
Dim folderPath As String, filename As String
Dim temp As Variant
Dim folder As Object, file As Object
Dim row As Integer, lastrow As Integer
MsgBox "Please select the folder containing all the input files", vbOKOnly
Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker)
folderDialog.AllowMultiSelect = False
folderDialog.Show
On Error GoTo ext
folderPath = folderDialog.SelectedItems(1)
Set temp = CreateObject("Scripting.FileSystemObject")
Set folder = temp.GetFolder(folderPath)
row = Sheet1.Cells(Rows.Count, 2).End(xlUp).row
If row > 3 Then Sheet1.Range("B4:I" & row).Clear
row = 4
For Each file In folder.Files
filename = file.Name
filename = Left(filename, Len(filename) - 5)
Application.Workbooks.Open (folderPath & "\" & filename)
lastrow = Workbooks(filename).Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).row
Workbooks(filename).Worksheets("Sheet1").Range("B4:I" & lastrow).Copy
Sheet1.Range("B" & row).PasteSpecial xlPasteValues
Sheet1.Range("B" & row).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
row = Sheet1.Cells(Rows.Count, 2).End(xlUp).row + 1
Application.Workbooks(filename).Close savechanges:=False
Next
ext:
If folderPath = "" Then
MsgBox "Folder not selected!"
Application.ScreenUpdating = True
Exit Sub
End If
Sheet1.Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Data successfully merged!", vbInformation
End Sub
You may need to enable the Microsoft Scripting Runtime library on your boss's computer if you haven't already. In some instances this library needs to be enabled in order to interface with the File System Object.
This library can be accessed from the Visual Basic Editor by pressing Tools > References > Microsoft Scripting Runtime. See the link below for further information.
Microsoft Scripting Runtime Library
Try this version
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\Test2\"
MyFile = Dir(MyDir & "*.xlsx") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Sheet1")
MsgBox "your code goes here -" & MyFile
' Rws = .Cells(Rows.Count, "B").End(xlUp).Row
' Set Rng = Range(.Cells(2, 1), .Cells(Rws, 2))
' Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
ActiveWorkbook.Close True
End With
Application.DisplayAlerts = 1
MyFile = Dir()
Loop
End Sub
1 scenario where the code finishes in a second is when you have selected an empty folder or selecting a folder containing other than excel files.
Try checking the correct folder to select and execute the code. It should work fine.