I am trying to make a consolidated financial statement, which shows all details of subsidiary and consolidated figure in the last column (I plan to use formula for total consolidated figure). I am trying to copy some specific column of worksheet (let's say column C) from selected files (each file has only one sheet with exacltly same layout, structure, and basic data) then paste it into one master sheet (newly added) to show detail of the column C from each file in column B of the master sheet from left to right. Also, I want to show the name of each file in row 1 of the master sheet, but I still can't figure out how to put it in my code.
Here is my code. So far, after I ran it in excel 2010, I found that every column are the same. I don't know what went wrong. I have more than 60 files to do this detailed consolidation. Any help woud be very much appreciated. Thank you.
Sub CombineSheetColumn()
Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
HeaderRow As Long
Dim DataRng As Range, OutRng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'initialize constants
HeaderRow = 2 'assume headers are always in row 2
LastOutCol = 1
'select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)
'loop through all selected files
For FileIdx = 1 To TargetFiles.SelectedItems.Count
'open the file and assign the workbook/worksheet
Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
Set DataSheet = DataBook.ActiveSheet
Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 3), DataSheet.Cells(32, 3))
Set OutRng = Range(OutSheet.Cells(HeaderRow + 1, 2), OutSheet.Cells(32, LastOutCol + 1))
'copy the data to the outbook
DataRng.Copy OutRng
'close the data book without saving
DataBook.Close False
'update the last outbook row
LastOutCol = OutSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Next FileIdx
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
to get the filename of the source workbook, you can use:
Cells(32, LastOutCol + 1).value=TargetFiles.SelectedItems(FileIdx).Name
and as for all the data being the same, you could step through and check the columns that are being copied in the source workbook in each iteration of the loop by adding a breakpoint on the line:
DataRng.Copy OutRng
Related
I have a challenge on achieving the below project, kindly please assist:
I have four source workbooks with names(GK,SK,RJ and TB).
Each workbook(GK,SK,RJ and TB) have three worksheets with the same names(products, channels, and sales).
I have destination workbook called consolidated workbook with the same worksheets names(products, channels, and sales) like those of the four source workbooks.
All workbooks(source + destinations) are in the same folder.
Iam requesting VBA code that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Currently I have the below code but whenever I ran it copies everything from worksheets on the source workbooks and paste to worksheets in consolidated workbook which result to duplicated data.
All the source workbook have worksheets with the "DATE" as a first column in each worksheet table column.
Destination workbook also have the same worksheet names and the same columns structure on each worksheet are the same as of those source worksheet.
Kindly advise what should I amend so that the code will that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see the amended code:
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range,
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As
Range
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
On Error Resume Next
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
Set fndRng = sh.Range("A:A").Find(date_to_find,LookIn:=xlValues,
searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
On Error GoTo 0
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see how consolidated workbook appear(the sheet names and column format are exactly the same as of the source workbooks.)
CONSOLIDATED WORKBOOK
The following line can be used to find the latest date loaded on your consolidated sheet:
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
The following lines can be used on a worksheet (sh) to create a range (for copying) that starts after the latest_date_loaded down to the bottom of the table. You'll therefore need to ensure this is in date order.
Dim fndRng As Range, start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As Range
date_to_find = latest_date_loaded
Set fndRng = sh.Range("A:A").Find(date_to_find, LookIn:=xlValues, searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
EDIT
Here is a rework of your code, using some of the lines/ideas I've mentioned above.
Sub Copy_From_All_Workbooks()
'declarations
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, _
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As _
Range, latest_date_loaded As Date, consolidated_wb As Workbook
'turn off screen updating for user experience
'Application.ScreenUpdating = False
'set a reference to the consolidated workbook
Set consolidated_wb = ThisWorkbook
'read parent folder of consolidated workbook
wb = Dir(consolidated_wb.Path & "\*")
'perform this loop until no more files
Do Until wb = ""
'make sure it doesn't try to open consolidated workbook (again)
If wb <> consolidated_wb.Name Then
'open found source workbook
Workbooks.Open consolidated_wb.Path & "\" & wb
'cycle through each sheet (sh)
For Each sh In Workbooks(wb).Worksheets
'on that sheet, find the latest date already existing
latest_date_loaded = Application.WorksheetFunction.Max(consolidated_wb.Sheets(sh.Name).Range("A:A"))
'find the last occurence of that date in column A
Set fndRng = sh.Range("A:A").Find(latest_date_loaded, LookIn:=xlValues, _
searchdirection:=xlPrevious)
'if you find that date already then..
If Not fndRng Is Nothing Then
'set the top row to where you found it, plus one
start_of_copy_row = fndRng.Row + 1
Else
'otherwise, it's a new sheet, start on row two
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
'find the end of the table, using column A's contents
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
'make sure there's something to copy
If end_of_copy_row >= start_of_copy_row Then
'create a reference to the block of cells to copy
Set range_to_copy = sh.Range(start_of_copy_row & ":" & end_of_copy_row)
'copy that range
range_to_copy.Copy
'paste them, values only
consolidated_wb.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'clear copy markings from screen
Application.CutCopyMode = False
Else
'otherwise, do nothing here
End If
Next sh
'close the source workbook
Workbooks(wb).Close False
End If
'get next potential filename
wb = Dir
Loop
'turn back on screen updating
Application.ScreenUpdating = True
End Sub
I'm very new to working with VBA.
I am trying to create a macro that allows the user to press a button that allows you to select any Excel workbook, regardless of name, and put the data at the bottom of a master list on the next blank cell. I've pasted the code that I currently have on VBA. Each time that I try to run the code, I get the Run-time error '9' for Subscript out of range.
Sub selectFile()
'Create and set dialog box as variable
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)
'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False
'Set the title of the DialogBox
dialogBox.Title = "Select a file"
'Set the default folder to open
dialogBox.InitialFileName = "C:\Users\ExcelDataFolder"
'Clear the dialog box filters
dialogBox.Filters.Clear
'Apply file filters - use ; to separate filters for the same name
dialogBox.Filters.Add "Excel workbooks", "*.xlsx;*.xls;*.xlsm"
'Show the dialog box and output full file name
If dialogBox.Show = -1 Then
'ActiveSheet.Range("filePath").Value = dialogBox.SelectedItems(1)
Dim strVar As String
strVar = Right$(dialogBox.SelectedItems(1), Len(dialogBox.SelectedItems(1)) - InStrRev(dialogBox.SelectedItems(1), "\"))
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
'Set variables for copy and destination sheets
Set wsCopy = Workbooks(strVar).Worksheets(1)
Set wsDest = Workbooks("DummyMaster.xlsm").Worksheets(1)
'1. Find last used row in the copy range based on data in column A
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
'2. Find first blank row in the destination range based on data in column A
'Offset property moves down 1 row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
'3. Copy & Paste Data
wsCopy.Range("A2:E" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
End If
End Sub
Try something like this.
Sub selectFile()
Dim strVar As String, wbCopy As Workbook, wsCopy As Worksheet
strVar = SelectExcelFile("C:\Users\ExcelDataFolder")
If Len(strVar) = 0 Then Exit Sub 'no file selected
Set wbCopy = Workbooks.Open(strVar)
Set wsCopy = wbCopy.Worksheets(1)
wsCopy.Range("A2:E" & wsCopy.Cells(Rows.Count, "A").End(xlUp).Row).Copy _
ThisWorkbook.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1)
wbCopy.Close SaveChanges:=False
End Sub
'ask the user to select an Excel file; optionally set the starting folder
Function SelectExcelFile(Optional startFolder As String = "") As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.title = "Select a file"
If Len(startFolder) > 0 Then .InitialFileName = startFolder
.Filters.Clear
.Filters.Add "Excel workbooks", "*.xlsx;*.xls;*.xlsm"
If .Show = -1 Then SelectExcelFile = .SelectedItems(1)
End With
End Function
Note that keeping your methods short is a good way to keep your code easy to maintain. One way to do that is to factor out specific tasks (like choosing a file for example) into separate methods.
I have two workbooks with sheets 1 & 2. I want to compare the header names of workbook1 sheet A (i.e. Range A1:BZ1) with the names in workbook2 sheet B column A.
I have tried copying the data into an array and then tried finding the heading files in the table column
Sub Multi_Find()
Dim sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim fullpath
Dim temp As Variant
Dim xyz As Variant
Application.ScreenUpdating = False
'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
With Application.FileDialog(msoFileDialogFilePicker)
'Makes sure the user can select only one file
.AllowMultiSelect = False
'Filter to just the following types of files to narrow down selection options
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
'It's a good idea to still check if the file type selected is accurate.
'Quit the procedure if the user didn't select the type of file we need.
If InStr(fullpath, ".xls") = 0 Then
Exit Sub
End If
'Open the file selected by the user
Workbooks.Open fullpath
Set wb2 = Workbooks("DBSteuerungsdatei.xlsm")
'Workbooks opened from microsoft explorer
Set wb1 = Application.Workbooks.Open(fullpath)
temp = Worksheets("Tabelle1").Range("A1:BZ1")
wb2.Activate
Set tbl = ActiveWorkbook.Sheets("LookUp").ListObjects("Table1")
'Create an Array out of the Table's Data
Set Temparray = tbl.DataBodyRange
myArray = Application.Transpose(Temparray)
'Designate Columns for Find/Replace data
fndList = 1
'Loop through each item in Array lists
For x = LBound(myArray, 1) To UBound(myArray, 1)
xyz = temp.Find(what:=myArray(fndList, x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False)
Next x
End Sub
if nothing is missing than the program should terminate
if a missing header from workbook 1 is found it should open an input box which allows user to enter correct names in column 1 and column 2 of the table
I solved the problem with the following code
I made sure that the files are selected using the windows dialog box
After selection, the header files were checked against the first column of the table and the new data was replaced from the second column
Sub Multi_FindReplace()
' This program checks the headers in sheets and update
' them according to the new header values from the Table
Dim sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim fullpath
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
'Makes sure the user can select only one file
.AllowMultiSelect = False
'Filter to just the following types of files to narrow down selection options
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
'It's a good idea to still check if the file type selected is accurate.
'Quit the procedure if the user didn't select the type of file we need.
If InStr(fullpath, ".xls") = 0 Then
Exit Sub
End If
'Open the file selected by the user
Workbooks.Open fullpath
Set wb2 = Workbooks("DBdata.xlsm")
'Workbooks opened from microsoft explorer
Set wb1 = Application.Workbooks.Open(fullpath)
wb2.Activate
'Create variable to point to your table
Set tbl = ActiveWorkbook.Sheets("LookUp").ListObjects("Table1")
'Create an Array out of the Table's Data
Set Temparray = tbl.DataBodyRange
myArray = Application.Transpose(Temparray)
'Designate Columns for Find/Replace data
fndList = 1
rplcList = 2
'Loop through each item in Array lists
For x = LBound(myArray, 1) To UBound(myArray, 2)
wb1.Activate
'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
For Each sht In wb1.Worksheets
If sht.name <> tbl.Parent.name Then
sht.Cells.Replace what:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
Next sht
Next x
MsgBox ("The changes in " & wb1.name & " are done!")
wb1.Close savechanges:=True
Application.ScreenUpdating = True
End Sub
I'm attempting to create a centralized database that imports the same tab (named "Import") from multiple workbooks into a tab on a different workbook.
I am new to VBA, and modifying code from VBA Import multiple sheets into Workbook and https://danwagner.co/how-to-combine-data-from-multiple-sheets-into-a-single-sheet/.
Only the data from the open file is imported into the database worksheet. I would like all the selected files' "Import" tabs to be brought in. Additionally, I'd like to not open any of the source files.
Sub InsertDatabase()
Dim FileNames As Variant 'Group of files to be looped through
Dim FileName As Variant 'Country of focus (file open)
Dim ActiveCountryWB As Workbook 'Active workbook of country
Dim wksSrcCountry As Worksheet 'Import worksheet in country
Dim wksDstDatabase As Worksheet 'Data worksheet in database
Dim rngSrcCountry As Range 'Range of data in import worksheet
Dim rngDstDatabase As Range 'Range of data in data worksheet in database
Dim lngSrcLastRow As Long
Dim lngDstLastRow As Long
'Set destination reference
Set wksDstDatabase = ThisWorkbook.Worksheets(1)
MsgBox "In the following browser, please choose the Excel file(s) you want to copy data from"
FileNames = Application.GetOpenFilename _
(Title:="Please choose the files you want to copy data FROM", _
FileFilter:="All Files (*.*),*.*", _
MultiSelect:=True)
If VarType(CountriesGroup) = vbBoolean Then
If Not CountriesGroup Then Exit Sub
End If
'Set initial destination range
lngDstLastRow = LastOccupiedRowNum(wksDstDatabase)
Set rngDstDatabase = wksDstDatabase.Cells(lngDstLastRow + 1, 1)
'Loop over all files selected by user, and import the desired "Import" sheet
For Each FileName In FileNames
'Set country workbook references
Set ActiveCountryWB = Workbooks.Open(FileName)
Set wksSrcCountry = ActiveCountryWB.Sheets("Import")
'Identify last occupied row on import sheet
lngSrcLastRow = LastOccupiedRowNum(wksSrcCountry)
'Store source data
With wksSrcCountry
Set rngSrcCountry = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, 20))
rngSrcCountry.Copy Destination:=rngDstDatabase
End With
'Redefine destination range now that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDstDatabase)
Set rngDstDatabase = wksDstDatabase.Cells(lngDstLawRow + 1, 1)
Next FileName
End Sub
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
The code you pulled online is honestly poorly put together. You do not need a function to determine the last row (as seen below). I would try this instead (clear your code out of the excel). The macro should follow the below steps:
1) Prompt user to select import files
2) Copy the data form "Import" sheet from Col A - T (down to last row) into your Database
3) Close the Import Book
4) Loop steps 2 & 3 until all Import books are covered
-Paste this code in a module
-Create a new sheet called "Data" (make sure it has headers or this will error out)
-If your Import sheets have headers you need to change the copy range from A1 to A2 (otherwise you will keep importing headers in the middle of your data)
Sub Database()
Dim CurrentBook As Workbook 'Import books
Dim ImportFiles As FileDialog
Dim FileCount As Long 'Count of Import books selected
Dim Database As Worksheet
Set Database = ThisWorkbook.Sheets("Data")
'Open File Picker
Set ImportFiles = Application.FileDialog(msoFileDialogOpen)
With ImportFiles
.AllowMultiSelect = True
.Title = "Pick import files"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
'Stop Alerts/Screen Updating
Application.DisplayAlerts = False
Application.DisplayAlerts = False
'Move Data from ImportBook(s) to Database
For FileCount = 1 To ImportFiles.SelectedItems.Count
Set CurrentBook = Workbooks.Open(ImportFiles.SelectedItems(FileCount))
'Determine Last Row on Import Book
Dim ImportLRow As Long
ImportLRow = CurrentBook.Sheets("Import").Range("A" & CurrentBook.Sheets("Import").Rows.Count).End(xlUp).Row
'Determine Last Row on Database Book
Dim DatabaseLRow As Long
DatabaseLRow = Database.Range("A" & Database.Rows.Count).End(xlUp).Offset(1).Row
'Copy Range
Dim CopyRange As Range
Set CopyRange = CurrentBook.Sheets("Import").Range("A1:T" & ImportLRow) 'If the sheets have headers, change this from A1 to A2
CopyRange.Copy
'Paste Range
Database.Range("A" & DatabaseLRow).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
'Close Import Book (Do not save)
CurrentBook.Close False
Next FileIdx
'Enable Alerts/Screen Updating
Application.DisplayAlerts = True
Application.DisplayAlerts = True
End Sub
I was really hoping I could figure this out but haven't had any luck. The following VBA allows users to import data from a separate file and determine unique variables to be analyzed, initiated by a single command button. The issue occurs as the final sub is called (filtering for unique variables). I have set .ScreenUpdating = false and set variables back to null after use. As for the sheets in the workbook, they currently do not contain data or formulas but will need to in order to analyze the data further.
Any help in identifying heavy memory usage would be appreciated.
64 bit is unfortunately not an option either
Located in Module1:
Global PathAndFile As String
Global FileName As String
Sub SelectFile()
Application.ScreenUpdating = False
Dim fd As FileDialog
Dim InDir As String
Dim wb As Workbook
InDir = CurDir() 'Save current directory
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = CurDir & "\" 'Startup folder
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "All Excel Files", "*.csv" 'Display csv files only
If .Show = False Then
MsgBox "User canceled without selecting."
ChDir (InDir) 'Change back to Initial directory if user cancels
Exit Sub
End If
'contains the path and filename of selected file
PathAndFile = .SelectedItems(1)
End With
'contains the filename (without the path)
FileName = Right(PathAndFile, Len(PathAndFile) - _
InStrRev(PathAndFile, "\"))
'Clear storage sheet
ThisWorkbook.Worksheets("DataTransferred").Cells.Clear
Call rData
End Sub
Sub rData()
'Retrieve Data
Dim lRow As Long
Dim lCol As Long
Dim Datawb As Workbook
'Open Selected workbook
Set Datawb = Workbooks.Open(PathAndFile)
With Datawb
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
'Find the last non-blank cell in row 1
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
'Copy data and paste in new this workbook
Range(Cells(1, 1), Cells(lRow, lCol)).Copy _
Destination:=ThisWorkbook.Worksheets("DataTransferred").Cells(1, 1)
End With
Workbooks(FileName).Close
'Clear Memory
lRow = 0
lCol = 0
strPathAndFile = vbNullString
strFileName = vbNullString
'Sort data
Call Worksheets("DataTransferred").VariableSelect '<<<Run-Time Error 7
Application.ScreenUpdating = True
End Sub
Located in Sheets("DataTransffered"):
Sub VariableSelect()
'Determine unique variables out of assortment
Dim rngDest As Range
If ThisWorkbook.Worksheets("DataTransferred").Cells = Empty Then Exit Sub
'Determine destination for varilables
Set rngDest = ThisWorkbook.Sheets("Analysis").Range("A1")
rngDest.ClearContents
'Select cells with in column (B) and apply filter
Me.Range(Me.Range("B1"), Me.Cells(Rows.Count, 2).End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rngDest, Unique:=True
End Sub