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.
Related
I have been working on the below code, however I am looking to edit this further:
1) Instead of setting 'Set Range1' via an input box, this should always be the cell range of 'B2:P65' when looping through the sheets in the folder.
2) When pasting the data I want this to fill starting at column B of the 'Database' tab in the workbook and then subsequently C, D, E etc.. for the rest of the workbooks in the folder loop.
Sub LoopFileUpload_base()
Dim wb As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
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
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
myExtension = "*.xlsx"
myfile = Dir(myPath & myExtension)
Do While myfile <> ""
Set wb = Workbooks.Open(fileName:=myPath & myfile)
'CHANGE CODE BELOW HERE
xTitleId = "Range"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
For Each Rng In Range1.Rows
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
rowIndex = rowIndex + Rng.Columns.Count
Next
'CHANGE CODE ABOVE HERE
wb.Close SaveChanges:=True
myfile = Dir
Loop
MsgBox "Task Complete!"
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Consider the following macro where you loop through .xlsx workbooks in a folder and iteratively copy cells in specified range to current sheet row by row. Then, after each workbook move to next column:
Sub TransposeWorkbooks()
Dim strfile As String
Dim sourcewb As Workbook
Dim i As Integer, j As Integer
Dim cell As Range
strfile = Dir("C:\Path\To\Workbooks\*.xlsx")
ThisWorkbook.Sheets("Database").Activate
ThisWorkbook.Sheets("Database").Range("A2").Activate
Do While Len(strfile) > 0
' OPEN SOURCE WORKBOOK
Set sourcewb = Workbooks.Open("C:\Path\To\Workbooks\" & strfile)
ThisWorkbook.Activate
ActiveCell.Offset(0, 1).Activate ' MOVE TO NEXT COLUMN
ActiveCell = strfile
' ITERATE THROUGH EACH CELL ACROSS RANGE
j = 1
For Each cell In sourcewb.Sheets(1).Range("B2:P65")
ActiveCell.Offset(j, 0).Value = cell.Value ' MOVE TO NEXT ROW
j = j + 1
Next cell
' CLOSE WORKBOOK
sourcewb.Close False
strfile = Dir
Loop
End Sub
It sounds like you got your task solved. For future reference, please try the AddIn from the link below. I think you will find so many uses for this tool.
http://www.rondebruin.nl/win/addins/rdbmerge.htm
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
I am a VBA newbie trying to figure out how to loop through a series of workbooks and their sheets in an effort to find a specific sheet but are having some trouble with my object variables.
Below is the code I have "written" (glued together might be a more apt description). I have tried various corrections but only seem to be moving the problem from one place to another. Any help will be appreciated!
Sub NestedForEach()
'Create an object variable to represent each worksheet
Dim WS As Worksheet
Dim WB As Workbook
Set WB = ActiveWorkbook
Set WS = Workbook.Sheets
'create a boolen variable to hold the status of whether we found worksheet "D"
Dim IsFound As Boolean
'initialise the IsFound boolean variable
IsFound = False
For Each WB In Application.Workbooks
For Each WS In WB.Worksheets
If WS.Name = "d" Then
IsFound = True
Exit For
End If
Next WS
Next WB
If IsFound Then
MsgBox "sheet D has been found in " & ActiveWorkbook.Name
Else
MsgBox "we could not locate sheet D in any of the open workbooks"
End If
End Sub
Only few changes were necessary in order to make your code work:
Option Explicit
Sub NestedForEach()
'Create a Worksheet variable to represent one worksheet
Dim WS As Worksheet
Dim WB As Workbook
'create a boolen variable to hold the status of whether we found worksheet "D"
Dim IsFound As Boolean
'initialise the IsFound boolean variable
IsFound = False
For Each WB In Application.Workbooks
For Each WS In WB.Worksheets
If WS.Name = "d" Then
IsFound = True
MsgBox "sheet D has been found in " & WB.Name
Exit Sub
End If
Next WS
Next WB
MsgBox "we could not locate sheet D in any of the open workbooks" & _
Chr(10) & "which are open in this instance of Excel" & _
Chr(10) & "(in case multiple Excels are running)"
End Sub
Let me know if you have any question regarding the changes.
Just 1 week ago I wrote a script to go to a specified folder (the user chooses) and list all Excel files and sheet names in that folder.
Public Sub LoopAllExcelFilesInFolder()
Dim WB As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim sht As Worksheet
Dim LastRow As Long
Application.DisplayAlerts = False
Sheets("ListFilesInFolder").Select
Set sht = ThisWorkbook.Worksheets("ListFilesInFolder")
sht.Activate
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
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 (must include wildcard "*")
myExtension = "*.xl*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Do While myFile <> ""
Set WB = Workbooks.Open(Filename:=myPath & myFile)
With Application
.AskToUpdateLinks = False
End With
For Each Sheet In Workbooks(myFile).Worksheets
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
Workbooks("Questionaire-Mock-Up.xlsb").Worksheets("ListFilesInFolder").Cells(LastRow, 1).Value = myPath & myFile
Workbooks("Questionaire-Mock-Up.xlsb").Worksheets("ListFilesInFolder").Cells(LastRow, 2).Value = myFile
Workbooks("Questionaire-Mock-Up.xlsb").Worksheets("ListFilesInFolder").Cells(LastRow, 3).Value = Sheet.Name
File = InStr(myFile, ".xl") - 1
LeftName = Left(myFile, File)
Workbooks("Questionaire-Mock-Up.xlsb").Worksheets("ListFilesInFolder").Cells(LastRow, 4).Value = LeftName
LastRow = LastRow + 1
Next Sheet
Workbooks(myFile).Close SaveChanges:=False
myFile = Dir
Loop
ResetSettings:
Application.DisplayAlerts = True
End Sub
I have a folder containing nearly 1,000 .csv files. I would like to grab the second column from each of these files and transpose-paste them into a new Excel workbook, so that the data is in one row.
The following is what i have so far:
Sub OpenFiles2()
Dim MyFolder As String
Dim MyFile As String
'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
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Do While myPath <> ""
Range(Range("B1"), Range("B1").End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveWorkbook.Close True
Windows("Compiled.xlsm").Activate
Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1,0).PasteSpecial Transpose:=True
MyFile = Dir
Loop
End Sub
For some reason I keep getting an error for the Paste Special command.
I also tried to replace it with:
ActiveSheet.PasteSpecial Transpose:=True
And
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= False, Transpose:=True
Still got errors. Please help. Thank you.
I would avoid using select and deal with the values. This code stores the original value in a variable, then you can close the active workbook and use the data in that variable by using the Application.Transpose within VBA.
Replace the Do Loop with the below code.
Do While myPath <> ""
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
x = Range("B1:B" & lastrow).Value
ActiveWorkbook.Close True
With Worksheets("Sheet1")
Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1). _
Resize(, lastrow).Value = Application.Transpose(x)
End With
MyFile = Dir
Loop
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