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
Related
I've hit a roadblock and I can't figure it out for the life of me. Here is what I am trying to accomplish:
A program I use exports a snapshot of the data into a spreadsheet (.xls) into the Downloads folder locally.
I need to copy the data of sheet1 of this spreadsheet (without opening it) into the main spreadsheet I have saved elsewhere which is the "main" sheet and open. I have a macro button on the main sheet that runs this code.
The caveat is that I have to make the Downloads folder dynamic in that it is not a specific username, because it is going to be used by multiple users.
This code works perfectly for 1 person:
Sub sbCopyingAFile()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
MyDir = "C:\Users\{My_Username}\Downloads\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets(1)
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(.Cells(2, 1), .Cells(Rws, 19))
Rng.Copy Wb.Worksheets("DUMP").Cells(Rows.Count, "B").End(xlUp).Offset(0, 0)
ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop
On Error Resume Next
Kill "C:\Users\{My_Username}\Downloads\*.*"
On Error GoTo 0
End Sub
This was my last attempt at getting any Downloads folder, not specific to a username:
Sub sbCopyingAFile()
Dim MyFile As String, Str As String, Wb As Workbook, MyDir As String
'Dim fso
Dim Rws As Long, Rng As Range
'Set fso = CreateObject("Scripting.FileSystemObject")
Set Wb = ThisWorkbook
MyDir = CreateObject("WScript.Shell").specialfolders("Downloads")
'MyDir = "C:\Users\{My_Username}\Downloads\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets(1)
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(.Cells(2, 1), .Cells(Rws, 19))
Rng.Copy Wb.Worksheets("DUMP").Cells(Rows.Count, "B").End(xlUp).Offset(0, 0)
ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop
On Error Resume Next
'Kill "C:\Users\{My_Username}\Downloads\*.*"
On Error GoTo 0
End Sub
You can use Environ$("Username") to get the current username. This will return a string.
So your path would look something along the lines of:
"C:\Users\" & Environ$("Username") & "\Downloads\"
You can also use Environ$("UserProfile") & "\Downloads\" in case the user set up their profiles in a weird place that isn't "C:\Users"
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
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
My code runs trough dozens of excel documents, selects range and gives the range to an array. I would like to add up the arrays to get a summarized data then paste the result to an existing worksheet.
The formula should be something like this:
rangeVar = oNewBook.Worksheets(1).Range("A1:D4").Value
sumRange = sumRange + rangeVar
Important! Some cells in the range is empty (I don't know is this matters). Also I would like to add up the values separately like sumRange(1,1)+rangeVar(1,1) ; sumRange(2,2)+rangeVar(2,2) , etc... How to do this?
You can check the code here:
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim oNewBook As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
Dim i As Integer, j As Integer
Dim summaryVar() As Variant
Dim rangeVar() As Variant
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'set output worksheet
Set OutputWs = ThisWorkbook.Worksheets("Teszt")
'Loop through each Excel file in folder
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
rangeVar = oNewBook.Worksheets(1).Range("A1:D4").Value
oNewBook.Close
'Copy selected items
With OutputWs
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutputWs.Range("A" & Lastrow & ":" & "D" & Lastrow) = Application.WorksheetFunction.Sum(rangeVar) 'summaryVar
Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd, skipBlanks:=False
Application.CutCopyMode = False
End With
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
S. Meaden answers this question wonderfully in How to add arrays?. Instead of trying to add the two arrays together, he makes use of Excel's pasteSpecial Addvalues function to add the original range's values to another range. Based on his code, something like the below should work.
Set tempWS = Sheets.Add
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
oNewBook.Worksheets(1).Range("A1:D4").Copy
tempWS.Range("A1:D4").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
Standard Excel Worksheet Functions will work on 1 and 2 dimensional arras.
Sub Test()
Dim array2(25, 25) As Double
Dim i As Integer, j As Integer
For i = 0 To UBound(array2, 1)
For j = 0 To UBound(array2, 1)
array2(i, j) = Int((Rnd * 100) + 1)
Next
Next
MsgBox WorksheetFunction.Sum(array2)
End Sub