Objective: To copy data from all the excel files kept in the folder to the master excel files. The data is being copied correctly. However, I am unable to close all the files which are read by the program. Have tried all these options: ActiveWorkbook.Close, Workbooks(MyFile).Close SaveChanges:=False, Workbooks(MyFile).Close SaveChanges:=False, but none is working.
How to solve the issue?
VBA Code:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
MyFile = Dir("C:\Desktop\Actual Files\")
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (MyFile)
Range("A2:O97").Copy
Windows("zmaster.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 15))
Application.ScreenUpdating = False
MyFile = Dir
Loop
End Sub
Creating a workbook variable and using this would be a clean way to do it. The aspects within this sub of activating workbooks and interacting with sheets that aren't fully referenced is a concern and you could improve it further by properly referencing these.
Also be careful with application.screenupdating=false if you disable it within a sub make sure that every exit point will restore it.
Sub LoopThroughDirectory()
Application.ScreenUpdating = False
Dim MyFile As String, wbData As Workbook
Dim erow
MyFile = Dir("C:\Desktop\Actual Files\")
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then
Application.ScreenUpdating = True
Exit Sub
End If
Set wbData = Workbooks.Open(MyFile)
Range("A2:O97").Copy
Windows("zmaster.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 15))
wbData.Close False
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Related
NB: I'm brand new to VBA and code in general
I've attempted to make a macro that collates data from multiple workbooks and imports it into a master workbook ('ZMaster').
The following code successfully copies data from the cell C5 in multiple workbooks (from file C:\AutoMelinh) and pastes them in a column in my 'ZMaster' workbook.
The issue is I get the error 'The data you are pasting isn't the same size as your selection. Do you want to paste anyway?'. This comes after every paste, so I have to click 'ok' every single time. The format of the cell that is copied, is merged (between C5 and D5). I think this is the issue however I don't know how to mitigate that in the VBA code:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\AutoMelinh\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "ZMaster.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Range("C5").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
EDIT: I was able to solve the issue by using
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\AutoMelinh\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "ZMaster.xlsm" Then
Exit Sub
End If
Application.DisplayAlerts = False
Workbooks.Open (Filepath & MyFile)
Range("C5").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Application.DisplayAlerts = True
Loop
End Sub
you are getting the warning because you are pasting one cell into 4 cells
this should work without using copy/paste
Sub LoopThroughDirectory()
Dim Filepath As String
Filepath = "C:\AutoMelinh\"
Dim MyFile As String
MyFile = Dir(Filepath)
Dim erow As Range
Dim wb As Workbook
Do While Len(MyFile) > 0
If MyFile = "ZMaster.xlsm" Then Exit Sub
Set wb = Workbooks.Open(Filepath & MyFile)
erow = Workbooks("ZMaster.xlsm").Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
erow.Value = wb.Sheets(1).Range("C5").Value
if isempty(erow) then erow.value = "----------"
wb.Close
MyFile = Dir
Loop
End Sub
I would like to open all workbooks in a filepath on my hard-drive and then copy table data from sheet 2 to Master workbook with the name of Master.
I found this code and have modified it to suit my needs but I'm stuck.
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\home\Se\058 \dxakmh\Desktop\TestMiljö\Prognosverktyg\Sektionsfil\Gruppfiler"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = “master.xlsm” Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Worksheets("FärdigÖnskemål").Range("A4:D4").Select
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("DataÖnskemål").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
Any help this friday?
According to your code, it's not clear what Worksheet is the destination sheet (the one you want to paste to), is it Sheet1 or Worksheets("DataÖnskemål").
Anyway, in my code it pastes to Sheet1, let me know if you meant something else.
Code
Option Explicit
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Long
Dim Filepath As String
Dim wb As Workbook
Filepath = "C:\home\Se\058 \dxakmh\Desktop\TestMilj?\Prognosverktyg\Sektionsfil\Gruppfiler\"
MyFile = Dir(Filepath)
Do While MyFile <> ""
If Not MyFile Like "master.xlsm" Then
Set wb = Workbooks.Open(Filepath & MyFile)
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
wb.Worksheets("DataÖnskemål").Range("A4:D4").Copy Destination:=Sheet1.Range("A" & erow)
wb.Close False
End If
MyFile = Dir()
Loop
End Sub
I would recommend using FileSystemObject instead:
Sub LoopThroughDirectory()
Dim MyFile As File
Dim erow As Long
Dim Filepath As String
Dim wb As Workbook
Dim FSO As New Scripting.FileSystemObject
Filepath = "C:\home\Se\058 \dxakmh\Desktop\TestMilj?\Prognosverktyg\Sektionsfil\Gruppfiler"
For Each MyFile In FSO.GetFolder(Filepath).Files
If Not MyFile.Name Like "master.xlsm" Then
Debug.Print MyFile.Path
Set wb = Workbooks.Open(MyFile.Path)
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
wb.Worksheets("DataÖnskemal").Range("A4:D4").Copy Destination:=Sheet1.Range("A" & erow)
wb.Close False
End If
Next
End Sub
You have to add Microsoft Scripting Runtime reference to your project.
You can read more here
I have a length code which opens set of files, unhides and navigates to a particular worksheet, copies a range and pastes that range in another workbook.
The problem is whenever the code opens these files a popup message to update links appears. I understand it can be solved with updatelinks = 0 however wanted to know where should i include this in my code.
Also the code takes time to execute, so is there any modifications for faster execution.
Sub mergeallinputworkbooks()
Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim MyPath As String
Dim MyFile As String
Dim FolderName As String
Dim oCell As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set wkbDest = ThisWorkbook
Set wksDest = wkbDest.Worksheets("Master Data")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
MyPath = FolderName
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "*.xls")
Do While Len(MyFile) > 0
Set wkbSource = Workbooks.Open(MyPath & MyFile)
Set wksSource = wkbSource.Worksheets("Scoring DB")
ActiveWorkbook.Unprotect ("pyroo123")
Sheets("Scoring DB").Visible = True
Sheets("Scoring DB").Select
Range("A4:W4").Copy
Windows("Performance Dashboard.xlsm").Activate
With Sheets("Master Data").Range("$A:$A")
With Sheets("Master Data")
Set oCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
oCell.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Windows("Performance Dashboard.xlsm").Activate
End With
wkbSource.Close savechanges:=False
MyFile = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
For you links issue, have a look at this post. There should be enough information there to give you a good indication of how and where to use the link update.
Now code suggestion:
To improve performance of your code, I would suggest not to interact with worksheet where not necessary. Rather than 'Copy and Past' assign the range to an array:
arrMyRange = Worksheets("SourceWorksheet").Range("A4:W4")
This will create your array. Now assign the array to your location:
Worksheets("DestinationWorksheet").Range("A1").Resize(UBound(arrMyRange, 1), UBound(arrMyRange, 2)).Value = arrMyRange
A1 can be changed dynamically if required.
Objective - extracting data from multiple workbooks (5 in total); pasting the data into a new workbook.
Problem/Issue:
1) After running the below VBA code it's able to copy data from all the 5 workbooks but while pasting it's pasting data for only one of them.
2) Pop-up window for Clipboard is full. I've written a code to clear the clipboard but it doesn't seem to function as I still get the pop-up window.
VBA Code:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim MyPath As String
MyPath = "Directory path"
MyFile = Dir(MyPath)
Do While Len(MyFile) > 0
If MyFile = "filename.xlsb" Then
End If
Workbooks.Open (MyPath & MyFile)
Range("A3:CP10000").Copy
ActiveWorkbook.Close
'calculating the empty row
erow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
a = ActiveWorkbook.Name
b = ActiveSheet.Name
Worksheets("Raw Data").Paste Range("A2")
Application.CutCopyMode = False ' for clearing clipboard
MyFile = Dir
Loop
End Sub
I tried two other commands below as well, but they seem to just return no data at all.
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow + 1, 1), Cells(erow + 1, 30)) `pasting the data`
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("A2")`pasting the data`
Update.
Here is the current code:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook
MyPath = "C:\Users\username\Downloads\PROJECTS\Project Name\Input file\"
MyFile = Dir(MyPath)
Do While Len(MyFile) > 0
If InStr(MyFile, "post_level.xlsb") > 0 Then
Set wb = Workbooks.Open(MyPath & MyFile)
Range("A3:CP10000").Copy
'calculating the empty row
erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End If
MyFile = Dir
Loop
ActiveWindow.Zoom = 90
End Sub
Update2.
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook
MyPath = "C:\Users\username\Downloads\PROJECTS\ProjectNameFolder\SubFolder\MainFolder\Input file"
MyFile = Dir("C:\Users\username\Downloads\PROJECTS\ProjectNameFolder\SubFolder\MainFolder\Input file\*.*")
Do While Len(MyFile) > 0
If InStr(MyFile, ".csv") > 0 Then
Set wb = Workbooks.Open(MyPath & MyFile)
Range("A3:CP10000").Copy
'calculating the empty row
erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End If
MyFile = Dir
Loop
End Sub
I hope I can help... There are multiple errors in your code, and I am not sure if I fixed them the way you'd want.
It would be useful to mention just one main mistake. You cannot have these 2 lines together:
If MyFile = "filename.xlsb" Then
End If
Between these lines you must put every procedure that you want to do IF he If condition is met. In the original case, if there was a file named "filename.xlsb", nothing would have happened, as you immediately closed the code block...
Try something similar to the following code. It worked for me to import data from all the files in the directory C:\Temp\ which have the extension of .xlsb
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Long
Dim MyPath As String
Dim wb As Workbook
MyPath = "C:\Temp\"
MyFile = Dir(MyPath)
Do While Len(MyFile) > 0
If InStr(MyFile, ".xlsb") > 0 Then
Set wb = Workbooks.Open(MyPath & MyFile)
Range("A3:CP10000").Copy
'calculating the empty row
erow = ThisWorkbook.Worksheets("Raw Data").Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets("Raw Data").Paste (ThisWorkbook.Worksheets("Raw Data").Range("A" & erow + 2))
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End If
MyFile = Dir
Loop
End Sub
Can you please hep me with this code. I want to transfer data from multiple files to one master sheet. I am getting error in last but one line of the code
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = "C:\Users\Nadeem\Desktop\2013\2G\"
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsm" Then 'zmaster is the master file in same folder
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Range("A2").Select
Range(Selection.End(xlToRight), Selection.End(xlDown)).Copy 'Copy Dynamic range
'ActiveWorkbook.Application.CutCopyMode = False
'ActiveWorkbook.Close SaveChanges:=False
Application.Workbooks("zmaster.xlsm").Worksheets("Sheet1").Activate 'Added this line
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'Paste in Dynamic Range
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1).Address)
MyFile = Dir
Loop
End Sub
Try commenting out or deleting the line shown:
Workbooks.Open (Filepath & MyFile)
Range("A2").Select
Range(Selection.End(xlToRight), Selection.End(xlDown)).Copy 'Copy Dynamic range
'ActiveWorkbook.Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False
Also, when you set the destination range Cells(erow,1) evaluates to its value (which is blank) instead of its address. So change that line to:
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1).Address)