Problem:
A problem in making a cell reference in VBA for source workbook name. Error 9 subscripts out of range.
Task I am doing?
Ex. I have to copy 32 columns out of 50 columns from a workbook(Master) into a new workbook. I am able to make a code to copy and paste the column in the required sequence in new workbook.
The master workbook is a template of a register to take peoples information and it saved with a new name.
I have more than 65 workbooks(Master) to copy. I was trying to make a cell reference where I paste the source workbook(Master) name. I am aware that source workbook has to be open will running VBA.
I made icell as variable to fetch that value from cell B2, where I pasted workbook name but code is not running.
Code attached
Any suggestion is highly appreciated.
Sub Copy_Paste()
Dim iCell As String
iCell = Workbooks("Crack it").Worksheets("Intro").Range("B2").Value
'B2 will store the name of source workbook for copying data which will keep on changing
Workbooks("iCell").Worksheets("Register").Range("E2:E50").Copy
Workbooks("Crack it.xlsm").Worksheets("Risk").Range("A2").PasteSpecial Paste:=xlPasteValues 'Refid
Workbooks("iCell").Worksheets("Register").Range("H2:H50").Copy
Workbooks("Crack it.xlsm").Worksheets("Risk").Range("B2").PasteSpecial Paste:=xlPasteValues 'Tags
Workbooks("iCell").Worksheets("Register").Range("A2:A50").Copy
Workbooks("Crack it.xlsm").Worksheets("Risk").Range("c2").PasteSpecial Paste:=xlPasteValues 'Name
Workbooks("iCell").Worksheets("Register").Range("Z2:Z50").Copy
Workbooks("Crack it.xlsm").Worksheets("Risk").Range("D2").PasteSpecial Paste:=xlPasteValues 'Element
...... code keeps on repeating till column 32th
End Sub
I ahve somethign similar, I read all the files located on a folder for your case you will save all the 65 Workbooks in a folder, then read each one of them with a loop, once it takes the first book opened you will take the info:
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1) & sItem + "\"
FilePathBox.Value = sItem
End With
NextCode:
GetFolder = sItem & "\"
Set fldr = Nothing
If you see my code above it taks the url of the folder, then I will start a process that will see file by file:
Private Sub UserForm_Activate()
UserForm1.Top = (Application.Height / 2) - (UserForm1.Height / 2) + 45
UserForm1.Left = (Application.Width / 2) - (UserForm1.Width / 2) + 200
UserForm1.Label1.Visible = True
Label1.Caption = ""
'-----------------------------------------THIS IS THE LOOP OFR EACH FILE INTO THE FOLDER--------------------------------------------------
MyPath = UserForm2.FilePathBox.Value
Dim strFilename As String
strFilename = Dir(MyPath & "*.txt", vbNormal)
filesc = 1
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Application.DisplayAlerts = False
If filesc >= 1 Then
showBarName.Caption = showBarName.Caption & strFilename
'Worksheets.Add(Worksheets(Worksheets.Count)).Name = "Data"
Call ThisWorkbook.XY_Data((UserForm2.FilePathBox.Value & strFilename), (strFilename & ""))
showBarName.Caption = "Generating XY Data for %PATH%/"
End If
filesc = filesc + 1
counter = counter + cols
strFilename = Dir()
Loop
'------------------------------------------END--------------------------------------------------------------------------------------------
Worksheets("Spec").Visible = True
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Spec" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
UserForm1.Hide
showBarName.Caption = "Saving File"
'THIS IS FOR XLSX
Application.StatusBar = "Save your file into the PNL Project path."
Application.DisplayAlerts = False
Dim hoja As Worksheet
For Each hoja In Sheets
If ActiveSheet.Name = "Data" Then
ActiveWindow.SelectedSheets.Delete
End If
Next hoja
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="Excel Workbooks (*.xlsx), *.xlsx")
If fileSaveName <> False Then
Application.ActiveWorkbook.SaveAs Filename:=fileSaveName, FileFormat:=51
End If
showBarName.Caption = "Generating XY Data for %PATH%/"
'This is to close the macro without saving
Application.StatusBar = "XY Data Generated by Yazaki <<erik.floresdelfin#mx.yazaki.com>>"
'ThisWorkbook.Close savechanges = False
Application.DisplayAlerts = True
End Sub
Then on the above code in some part I take each file in txt format, and I call a method which contains the url of the file that I want to open, the rest should be taking what tou need to copy and paste on the actual file, the final code I show is how to save the file asking to the user, sorry for the trash code but I think you caould manage taking what you need.
Related
Newbie here.
So I have a dozen of these TXT/DTA files that look something like this and I want to stack them side by side. I want each file appended to the right, merged into one big file
Not knowing much about VBA I looked around and merged a few codes that seems to do it for xlsx files but doesn't for DTA files which is what I have. The code asks for a folder and loops through the files one by one.
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
'---Open the first file only
Workbooks.Open (MyFile)
Workbooks(MyFile).Worksheets("Sheet1").Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy Workbooks("CV Combined.xlsm").Worksheets("Sheet1").Range("A1")
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(fileName:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
Workbooks.Open (MyFile)
Workbooks(MyFile).Worksheets("Sheet1").Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy Workbooks("CV Combined.xlsm").Worksheets("Sheet1").Range("A1").End(xlToRight).Offset(0, 1)
Workbooks(MyFile).Close SaveChanges:=False
wbk.Close SaveChanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub
Any help would be appreciated.
MyFile = Dir(MyFolder) returns only the filename in MyFile so to open the first file use Workbooks.Open (MyFolder & MyFile). When the text file is opened the sheet name is the filename so Workbooks(MyFile).Worksheets("Sheet1") needs to be Workbooks(MyFile).sheets(1). Because your text file only has data in column A on row 1 Selection.End(xlToRight) will go the last column on the sheet XFD1 and then Selection.End(xlDown) will go to the last row XFD1048576.
Option Explicit
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbDTA As Workbook 'Used to loop through each workbook
Dim ws As Worksheet, wsDTA As Worksheet, rng As Range
Dim iCol As Long, n As Long
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
Set ws = Workbooks("CV Combined.xlsm").Sheets(1)
iCol = 1
'Loop through all files in a folder until DIR cannot find anymore
Application.ScreenUpdating = False
MyFile = Dir(MyFolder)
Do While MyFile <> ""
Set wbDTA = Workbooks.Open(MyFolder & MyFile, False, False)
Set wsDTA = wbDTA.Sheets(1)
Set rng = wsDTA.UsedRange
rng.Copy ws.Cells(1, iCol)
iCol = iCol + rng.Columns.Count + 1 ' add blank column
n = n + 1
wbDTA.Close SaveChanges:=False
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
MsgBox n & " files imported from " & MyFolder, vbInformation
End Sub
I have 50 files that are linked to each other to varying degrees. Each month all files must be moved to a different folder (new issue) with updated names to reflect the new month (ie. Sales 445F - 06-2019 to Sales 446F - 07-2019).
To do so, I believe I need to open all 50 files, before renaming, so that the links will be updated to the new name and the new file location.
Below is the macro I created keying off a column that identifies the files to be opened and then a second column that identifies the new name of the file.
Although the macro creates new files in the right location with the right names, the files created are all the same (the last file opened) and the links still remain attached to the old file names and locations. Suggestions?
Private Sub CommandButton1_Click()
For i = 10 To 59
pathname = Range("B5").Value
Filename = Range("B" & i).Value
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Workbooks.Open Filename:=pathname & Filename
Next i
MsgBox ("All Files Have Been Opened")
For i = 10 To 59
pathname2 = Range("C5").Value
filename2 = Range("C" & i).Value
ActiveWorkbook.SaveAs Filename:=pathname2 & filename2
Next i
MsgBox ("All Files Have Been Saved in the New Folder. A Final Save to Update Links to Point to the New Folder Will Now Begin")
Dim wb As Workbook
Dim wbStayOpen1 As String
Dim currentwb As String
wbStayOpen1 = "C:\Users\Desktop\Custom Macros\Open Rename and Save to New Folder.xlsm"
currentwb = ThisWorkbook.Name
For Each wb In Workbooks
If wb.Name <> wbStayOpen1 And wb.Name <> currentwb Then
wb.Close SaveChanges:=True
End If
Next wb
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
End Sub
It always saves the exact same workbook because you use ActiveWorkbook.SaveAs and the active one does never change. Avoid using ActiveWorkbook. Instead set all workbooks to an array of opened workbooks wbOpen(iStart To iEnd) that you can easily access then in your second loop. And also use it to close them in your third loop.
Never number your variable names. This is a very bad practice and if you think you need to do that you are doing something wrong. Actually there is no need to declare pathname2 and filename2 you can re-use the first variable.
Option Explicit
Private Sub CommandButton1_Click() 'make sure to give it a proper name
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet 'better declare sheet name like `ThisWorkbook.Worsheets("Sheet1")
'if the start and end is dynamic make them variables instead of constants
Const iStart As Long = 10
Const iEnd As Long = 59
ReDim wbOpen(iStart To iEnd) As Workbook
Dim PathName As String
Dim FileName As String
'open workbooks
Dim i As Long
For i = iStart To iEnd
PathName = wsSource.Range("B5").Value
FileName = wsSource.Range("B" & i).Value
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Set wbOpen(i) = Workbooks.Open(FileName:=PathName & FileName)
Next i
MsgBox ("All Files Have Been Opened")
'save workbooks
For i = iStart To iEnd
PathName = wsSource.Range("C5").Value
FileName = wsSource.Range("C" & i).Value
wbOpen(i).SaveAs FileName:=PathName & FileName
Next i
MsgBox ("All Files Have Been Saved in the New Folder.")
'close workbooks
For i = iStart To iEnd
wbOpen(i).Close SaveChanges:=True
Next i
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
End Sub
I am trying to:
open up spreadsheets from a folder of 50
sort and filter the first sheet on each one (the name will be unknown of this sheet)
filtering needs to find each row that has a certain value in column J - this value is 'No'
All rows that meet the criteria (row J contains 'no') need to be then placed onto a master spreadsheet
Each csv should close each time it's been processed
I have spent hours & hours on forums and have some code which I have been tinkering with, but can't get it running together:
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
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
'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 (must include wildcard "*")
myExtension = "*.csv*"
'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)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
Range("A1:AC3100").Select
Selection.AutoFilter
ActiveWindow.LargeScroll ToRight:=1
Range("Y2").Select
ActiveSheet.Range("$A$1:$AC$3110").AutoFilter Field:=25, Criteria1:="No"
Range("A1:AC3100").Select
Range("Y2").Activate
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Windows("Book1").Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown
'Save and Close Workbook
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
The spreadsheet data has variable lengths do I made the selection the maximum:
Range("A1:AC3100")
I would assume there is a better way than this too.
Your criterion is a bit too vague to give a perfect response, but I'll take a crack at it. Some parts of your code seem extraneous or convoluted so I'm doing this based on your end goal (all rows where the value in column J for the first sheet in each workbook that contain 'no' are copied into a master spreadsheet).
If all of your worksheets are always in the same folder you can make the myPath static rather than attempting to use the msoFileDialogFolderPicker. When I attempted to run your code on my machine it gave me an "Out of Memory" error, if you have this issue as well I recommend a static string for myPath.
Option Explicit
Sub PutInMasterFile()
Dim wb As Workbook
Dim masterWB As Workbook
Dim rowNum As Integer
Dim copyRange As Range
Dim pasteRange As Range
Dim myPath As String
Dim myFile As String
Dim FirstAddress As String
Dim x As Variant
Dim c As Variant
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
I would advise against disabling Events until you have confirmed your code is running correctly. Worry about getting working code before thinking about optimization.
x = 1
Set masterWB = Workbooks("NAMEOFWORKBOOK")
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
myPath = "C:\EXAMPLE\MOREEXAMPLE\*.csv"
myFile = Dir(myPath)
myPath can be set to search directly for .csv files in the string.
Do While myFile <> vbNullString
Workbooks.Open (myFile)
With Workbooks(myFile).Sheets(1)
Set c = .Range("J:J").Find("No", LookIn:=xlValues, lookat:=xlWhole)
Using .find in vba is preferential to trying to get a filter and then grabbing everything that the filter displays.
If Not c Is Nothing Then
FirstAddress = c.Address
Do
rowNum = c.Row
Set copyRange = .Range(rowNum & ":" & rowNum)
copyRange.Copy
pasteRange.PasteSpecial
x = x + 1
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
Copies in the row into your master sheet. The x = x + 1 guarantees you paste new data onto a new row to avoid overwriting anything.
Set c = .Range("J:J").FindNext(c)
Loop While Not c Is Nothing And FirstAddress <> c.Address
End If
End With
Workbooks(myFile).Close
myFile = Dir()
Closes your first file and gets the next one set up
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
Sets the paste range in the master wb outside of the inner loop, otherwise it will overwrite the values starting at A1 again with the next file.
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I would also recommend you read up on VBA best practices for any future code you work on such as using Option Explicit and avoiding use of GoTo or .Select wherever possible.
Edit: After user3561813 the suggestion of adding "/", it now read the first file. I have an out of range error message "9". It does read the first file correctly. Ultimately I am trying to open each file, and read the name and age (this is a testing not the real production form). And retrieve the values back to my main worksheet.
Original question
I am trying to read hundred of excel forms in a folder, read a particular cell position, and record them into my testing worksheet. I googled this tutorial and tried to write my code. But when I execute the Getting Folder function, selected a folder path, it does not loop the excel files I have. (or record their names)
'Source: https://www.youtube.com/watch?v=7x1T4s8DVc0
Sub GettingFolder()
Dim SelectedFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select folder"
.ButtonName = "Confirm"
.InitialFileName = "U:\"
If .Show = -1 Then
'ok clicked
SelectedFolder = .SelectedItems(1)
MsgBox SelectedFolder
' This is where I want to call my function
LoopFiles (SelectedFolder)
Else
'cancel clicked
End If
End With
End Sub
' Source: http://www.excel-easy.com/vba/examples/files-in-a-directory.html
Sub LoopFiles(path As String)
Dim directory As String, fileName As String, sheet As Worksheet
Dim i As Integer, j As Integer
' Avoid Screen flicker and improve performance
Application.ScreenUpdating = False
' Fixed per suggestion below..
directory = path & "\"
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
i = i + 1
j = 2
Cells(i, 1) = fileName
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
Workbooks("Testing.xlsm").Worksheets(1).Cells(i, j).Value = sheet.Name
j = j + 1
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
' Reset the screen update setting
Application.ScreenUpdating = True
End Sub
Interesting question! This should do it for you. Modify as needed.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
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
'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 (must include wildcard "*")
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Row = 1
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Change First Worksheet's Background Fill Blue
ThisWorkbook.Worksheets("Sheet1").Range("A" & Row).Value = Worksheets(1).Range("A1").Value
Row = Row + 1
'Save and Close Workbook
wb.Close SaveChanges:=True
'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
In your code, the path variable may not contain a trailing backslash. This causes the following code in your LoopFiles(<>) SubRoutine to be inaccurate:
directory = path
fileName = Dir(directory & "*.xl??")
Filename would look something like: c:\users\name\documentshello.xlsx
Try changing the above code to:
directory = path & "\"
fileName = Dir(directory & "*.xl??")
Does that fix the problem?
I'm new to VBA so not exactly sure how this all works but I've got the jist.
I am trying to import data from multiple workbooks into one workbook that is created by the program. I have got the main importing done correctly (although not effeciently) but then one of three things happens: The data is imported into correct places and is fine, the data overlaps after the first set, or only the first set of data is transferred. I just can't work out why!
Do
Filename = InputBox("What is the full path and name of the file?")
Workbooks.Open (Filename)
data_range = InputBox("What is the cell range of the wanted data in the original file? If this is the first set of data, include the titles for reference")
ActiveSheet.Range(data_range).Select
Selection.Copy
ActiveWorkbook.Close
If first = True Then
ActiveSheet.Range("b2").Select
End If
If first = False Then
ActiveSheet.Range("b" & (difference + 3)).Select
End If
ActiveSheet.Paste
ActiveSheet.Range("a1").Select
again = MsgBox("Would you like to import another set of data?", 4)
Call start_cell(range_of_cells, data_range)
first = False
Loop Until again = vbNo
That was the main program. The sub-procedure start_cell is below:
range_of_cells = Split(data_range, ":")
NUMBERS(0) = Right(range_of_cells(0), 2)
NUMBERS(1) = Right(range_of_cells(1), 2)
check = IsNumeric(NUMBERS(0))
If check = False Then
'wrong
End If
check = IsNumeric(NUMBERS(1))
If check = False Then
'wrong
End If
difference = (NUMBERS(1) - NUMBERS(0)) + difference
Any help would be awesome. Also if there are any more effecient ways that'd be great.
This is a sketch of what could work, check it, run it, customize it and let me know if something isn't working or I misunderstood your question.
Function GetFolder(ByVal sTitle As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = sTitle
.Show
On Error Resume Next
GetFolder = .SelectedItems(1)
On Error GoTo 0
End With
End Function
Sub Main()
Const START_ADDR As String = "A17"
Dim sPath As String, sFile As String
Dim wbLoop As Workbook
Dim wsLoop As Worksheet, wsConsolidate As Worksheet
Dim rData As Range
'save current sheet in variable (change if required)
wsConsolidate = ActiveSheet
'ask for folder
sPath = GetFolder("Select the folder where your files reside.")
'if none provided quit
If sPath = "" Then
MsgBox "No folder selected."
Exit Sub
End If
'get all excel files from specified folder
sFile = Dir(sPath & "\*.xls*")
Do Until sFile = ""
'open file
Set wbLoop = Workbooks.Open(sPath & "\" & sFile)
Set wsLoop = wbLoop.Sheets(1) 'change if other
'copy data out
Set rData = wsLoop.Range(START_ADDR).CurrentRegion
'if the data has headers uncomment below
'Set rData = rData.Offset(1, 0).Resize(rData.Rows.Count)
rData.Copy wsConsolidate.Cells(wsConsolidate.Rows.Count, "B").End(xlUp).Offset(1, 0)
'close file without saving
wbLoop.Close False
'loop through files
sFile = Dir
Loop
End Sub