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
Related
not my code completely.borrowed it from net with my changes in between
PURPOSE: To loop through all Excel files in a user specified folder and
perform a set task on them
SOURCE: www.TheSpreadsheetGuru.com
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
'Retrieve Target Folder Path From User
myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B2").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B3").Value & "\"
End Sub
not my code completely.borrowed it from net with my changes in between
PURPOSE: To loop through all Excel files in a user specified folder and
perform a set task on them
SOURCE: www.TheSpreadsheetGuru.com
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
'Retrieve Target Folder Path From User
myPath = ThisWorkbook.Worksheets(1).Range("B1").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B2").Value & "\" &
ThisWorkbook.Worksheets(1).Range("B3").Value & "\"
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
WS_Count = wb.Worksheets.Count
' Begin the loop.
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For I = 1 To WS_Count
'Change First Worksheet's Background Fill Blue
'following snippet arranges data in the 4th row and colors it
With wb.Worksheets(I)
If (Range("A1") <> "") Then
'Find the last used row in a Column: column A in this example
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim LastCol As Integer
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
LastColcell = Cells(1, LastCol).Address
Range("A1:" & LastColcell).Font.Color = vbWhite
Range("A1:" & LastColcell).Interior.Color = RGB(51, 98, 174)
Rows("1:3").Insert Shift:=xlDown
Range("G1").FormulaR1C1 = "=SUBTOTAL(9,R[5]C:R[" & LastRow & "]C)"
Range("G1").AutoFill Destination:=Range("G1:" & LastColcell)
Range("G1:" & LastColcell).Interior.Color = RGB(255, 255, 0)
AutoFilterMode = False
End If
End With
Next I
'Save and Close Workbook
Dt = Format(Date, "yyyymmdd")
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'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
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
Whenever I run this code I get: Run-time error '9' Subscript out of range. Can't figure out how to fix this error, please help.
The code runs trough excel files in a selected folder and copy pastes the selected row.
In the next step I would like to extend the code, to store and sum each cell value like this:
var1 = var1 + range("A5").value
But first please help me how to fix this error. Thank you.
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
'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
OutputWs = ThisWorkbook.Worksheets(Test)
'Loop through each Excel file in folder
Do While myFile <> ""
Workbooks.Open (myPath & myFile)
Range("A1:D3").Copy
ActiveWorkbook.Close
Lastrow = OutputWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Test").Range(Cells(Lastrow, 1), Cells(Lastrow, 4))
'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
To set an object reference to your worksheet, you need the keyword Set included:
Set OutputWs = ThisWorkbook.Worksheets("yoursheetname")
The get next file name should also be myFile = Dir and not include the parenthesis.
I took a closer look at the code and it appears that you're not explicitly defining which books are which in each case, meaning that the "orphaned" range statements can cause you problems. The 1004 error though is coming from your Paste statement, which I have corrected for you in the following code:
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
'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("Test")
'Loop through each Excel file in folder
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
oNewBook.Worksheets(1).Range("A1:D3").Copy
oNewBook.Close
Lastrow = OutputWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With OutputWs
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutputWs.Paste .Range("A" & Lastrow & ":" & "D" & Lastrow)
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
Note that this code assumes that you want to copy from the first worksheet of the opened workbook (hence the oNewBook.Worksheets(1) added to the Range.Copy statement)
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
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