For example,
I have 10 classes' exam result.
Each class have their own workbook.
Each workbook have 3 worksheet : English Result, Math Result and Physics Result
How can I get all the Math Result from all the classes and combine it to 1 worksheet?
I tried to write an If-statement to do it but there are some errors.
The code I currently using can only get the result from the workbook that have only 1 worksheet.
Please help me!
Here are the codes I current using:
Sub CombineDataFiles()
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, _
LastDataRow As Long, LastDataCol As Long, _
HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range
'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1
'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Show
End With
'error trap - don't allow user to pick more than 2000 files
' Can Modify By Changing the 2000
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
Exit Sub
End If
'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)
'loop through all 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
'identify row/column boundaries
LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'if this is the first go-round, include the header
If FileIdx = 1 Then
Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
'if this is NOT the first go-round, then skip the header
Else
Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
End If
'copy the data to the outbook
DataRng.Copy OutRng
'close the data book without saving
DataBook.Close False
'update the last outbook row
LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' On Error Resume Next
' Range (A1;K100000).Select
' Selection
Next FileIdx
'let the user know we're done!
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")
End Sub
if I understand you right, you want to consolidate lists of data of the same shape (same number and order of columns) from different workbooks. Microsoft has a nice documentary on this:
https://msdn.microsoft.com/en-us/library/cc793964(v=office.12).aspx
Related
I would Like to only copy the information in Range A2:P13. This Data gets spit out In different rows from time to time, and some times additional data in some of the columns gets added. I wrote a script that allows me to Select and copy everything from the last row to an x number rows up. Problem is that this amount of rows can be variable And there is way more data above the shared image (its clutter). Is there a way to modify my script so it counts down to the last row and once it hits "n" or "Calibration" it selects 8 rows above it?
Thanks in advance :)
enter image description here
Option Explicit
Sub Import_File()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim myValue As Variant
Dim Sht2 As Worksheet
Dim lastRow As Long
Dim Last24Rows As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
myValue = InputBox("Please Input Run Number")
FileToOpen = Application.GetOpenFilename("Excel Files (*.xl*),*.xl*", , "Choose File", "Open", False)
If FileToOpen = False Then
Exit Sub
Else
Set OpenBook = Workbooks.Open(FileToOpen)
Set Sht2 = OpenBook.Sheets("Sheet1")
End If
lastRow = Sht2.Range("H" & Sht2.Rows.Count).End(xlUp).row
Set Last4Rows = Sht2.Range("A" & lastRow - 4 & ":AZ" & lastRow)
Last4Rows.Copy
ThisWorkbook.Worksheets(myValue).Range("A1").PasteSpecial xlPasteValues
OpenBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I tried Including this
' Dim wb As Workbook
' Dim ws As Worksheet
' Dim FoundCell As Range
' Set wb = ActiveWorkbook
' Set ws = ActiveSheet
'
' Const WHAT_TO_FIND As String = "Calibration"
'
' Set FoundCell = ws.Range("A:A").Find(What:=WHAT_TO_FIND)
' If Not FoundCell Is Nothing Then
' MsgBox (WHAT_TO_FIND & " found in row: " & FoundCell.Row)
' Else
' MsgBox (WHAT_TO_FIND & " not found")
' End If
But it did not work
This will select 8 rows above wherever it finds "calibration". The -8 makes it move up 8 rows, and then the resize(8) resizes it to include the 8 rows below. It will create an error if it can't find "calibration", it would be easy to change that to send a text box instead.
Sub Macro1()
'
' Macro1 Macro
'
'
Dim found As Range
Dim SelectionRange As Range
Dim what_to_find As String
Dim FoundRow As Long
what_to_find = "calibration"
Set found = Cells.Find(What:=what_to_find, After:=ActiveCell, LookIn:=xlFormulas2, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
FoundRow = found.row
Set SelectionRange = Rows(FoundRow - 8).Resize(8)
SelectionRange.Select
End Sub
I want to fill in the workbook that holds the macro with data from another workbook. The data I need to copy can be on different columns on the source file, depending on the way this source file is generated. So I may run into a problem, because I might get the data I want on a wrong column, or I may even get data I do not want. So I guess it's better to look for the column header (which are always the same string, no matter how the report is generated). I can use the Find method to search for the headers, but how to copy the rows below each header? The range where I want the data pasted are always the same ranges on the paste workbook, and always the first sheet.
Following is my current code:
Sub Import()
' Looks up for the Source Report file and imports its data into wkbk that holds the macro
On Error Resume Next
' Defines Source Report file variable
Dim SourceFile As Variant
' Opens the SourceFile
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
End If
SourceFileDir = Dir(SourceFile)
' Looks up the last row on SourceFile to copy the entire data later
With Workbooks(SourceFileDir).Worksheets(1)
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' MsgBox ("The last row of data in the Source File is " & LastRow)
' Sets echo off before copying
Application.ScreenUpdating = False
' Copies SourceFile data into paste file, the one that holds the macro
' Serial Number
Workbooks(SourceFileDir).Worksheets(1).Range("E7:E" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("A38").PasteSpecial xlPasteValues
' Product ID
Workbooks(SourceFileDir).Worksheets(1).Range("A7:A" & LastRow).Copy
ThisWorkbook.Worksheets(1).Range("B38").PasteSpecial xlPasteValues
' Gets out of copy mode
Application.CutCopyMode = False
' Sets echo back on
Application.ScreenUpdating = True
End Sub
The total number of columns I need is 9, the code above just shows two of them, Serial Number and Product ID.
Thanks for your help.
Workbook to Workbook
Adjust the values in the constants section and right below in the Headers array.
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim Headers As Variant
Headers = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(Headers)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=Headers(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=Headers(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
End Sub
EDIT:
Since some of the headers have different values (names) on each sheet you should use two arrays (one for each sheet) and adjust the values appropriately:
Option Explicit
Sub Import()
' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro
Const LastRowColumnS As Long = 1
Const FirstRowS = 7
Const FirstRowP = 38
Dim HeadSource As Variant
Dim HeadPaste As Variant
HeadSource = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
HeadPaste = Array("Serial Number", "Product ID", "ID", _
"Name4", "Name5", "Name6", _
"Name7", "Name8", "Name9")
Dim rng As Range
Dim SourceFile As Variant
Dim wsS As Worksheet
Dim wsP As Worksheet
Dim LastRowS As Long
Dim CurColS As Long
Dim CurColP As Long
Dim NumberOfRows As Long
Dim Count As Long
Dim i As Long
' Opens Source File.
MsgBox ("Open the SourceFile")
SourceFile = Application.GetOpenFilename( _
FileFilter:="Excel Files,*.xl*;*.xm*")
If SourceFile <> False Then
Workbooks.Open Filename:=SourceFile
Else
MsgBox "You selected cancel."
Exit Sub
End If
' Define worksheets.
Set wsS = ActiveWorkbook.Worksheets(1)
Set wsP = ThisWorkbook.Worksheets(1)
' Define last cell with data in Last Row Column of Source Sheet.
Set rng = wsS.Columns(LastRowColumnS).Find( _
What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rng Is Nothing Then
MsgBox "No data in column."
Exit Sub
End If
NumberOfRows = rng.Row - FirstRowS + 1
For i = 0 To UBound(HeadSource)
' Define column of Current Header in Source Sheet.
Set rng = wsS.Cells.Find(What:=HeadSource(i), _
After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColS = rng.Column
' Define column of Current Header in Paste Sheet.
Set rng = wsP.Cells.Find(What:=HeadPaste(i), _
After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
CurColP = rng.Column
' Write data from Source Sheet to Paste Sheet.
wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
= wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
' Count the transfer.
Count = Count + 1
End If
End If
Next i
' Maybe close Source Workbook.
'wsS.Parent.Close False
MsgBox "Transferred data from '" & Count & "' columns."
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 have the following code albeit incomplete as i am unsure how i can populate multiple columns and rows.
Code
Sub VlookMultipleWorkbooks()
Dim lookFor As Range
Dim srchRange As Range
Dim book1 As Workbook
Dim book2 As Workbook
Dim book1Name As String
book1Name = "destination.xls" 'modify it as per your requirement
Dim book1NamePath As String
book1NamePath = ThisWorkbook.Path & "\" & book1Name
Dim book2Name As String
book2Name = "source.xls" 'modify it as per your requirement
Dim book2NamePath As String
book2NamePath = ThisWorkbook.Path & "\" & book2Name
' Set book1 = ThisWorkbook
Set book1 = Workbooks(book1Name)
If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
Set book2 = Workbooks(book2Name)
Set lookFor = book1.Sheets(1).Cells(2, 1) ' value to find
Set srchRange = book2.Sheets(1).Range("A:B") 'source
lookFor.Offset(0, 1).Value = Application.VLookup(lookFor, srchRange, 2, False)
End Sub
My source file has the following structure
Name Value1
My destination file has the following structure
Name Value1
Problem 1
Currently the code only populates a single cell where i would like it to populate allow rows.
Problem 2
I need to be able to populate multiple columns. For example.
Name Value1 Value2, etc
Problem 3
There are multiple source files that need to merge into a single master list.
EDIT: You could modify your initial design to take in two Range objects and an offset, then iterate as necessary. You'll need to open your workbooks and assign the Range objects elsewhere, but that doesn't seem to be the challenge right now. (Below is untested):
Sub EvenCoolerVLookup(SourceRange As Range, OffsetColumns As Long, LookupRange As Range)
Dim Cell As Range
'vet range objects and make sure they fail an Is Nothing test
'....
For Each Cell In SourceRange
'do any special prep here
'...
Cell.Offset(0, OffsetColumns).Value = Application.VLookup(Cell, LookupRange, 2, False)
'do any special cleanup here
'...
Next Cell
'do anything else here
'....
End Sub
That should help you solve Problem 1. To solve Problem 2, you won't be able to use Application.Vlookup, but you can instead use Range.Find to return a Range object, from which you can grab the row via Range.Row.
Original Response: This should work to combine source files for Problem 3. The results will be saved as an xlsx file to the same directory as the file from which the code is run:
Option Explicit
'let's do some combining y'all!
Sub CombineSelectedFiles()
Dim TargetFiles As FileDialog
Dim TargetBook As Workbook, CombinedBook As Workbook
Dim TargetSheet As Worksheet, CombinedSheet As Worksheet
Dim TargetRange As Range, AddNewRange As Range, _
FinalRange As Range
Dim LastRow As Long, LastCol As Long, Idx As Long, _
LastCombinedRow As Long
Dim CombinedFileName As String
Dim RemoveDupesArray() As Variant
'prompt user to pick files he or she would like to combine
Set TargetFiles = UserSelectMultipleFiles("Pick the files you'd like to combine:")
If TargetFiles.SelectedItems.Count = 0 Then Exit Sub '<~ user clicked cancel
'create a destination book for all the merged data
Set CombinedBook = Workbooks.Add
Set CombinedSheet = CombinedBook.ActiveSheet
'loop through the selected workbooks and combine data
For Idx = 1 To TargetFiles.SelectedItems.Count
Set TargetBook = Workbooks.Open(TargetFiles.SelectedItems(Idx))
Set TargetSheet = TargetBook.ActiveSheet
If Idx = 1 Then
TargetSheet.Cells.Copy Destination:=CombinedSheet.Cells(1, 1)
Else
LastRow = FindLastRow(TargetSheet)
LastCol = FindLastCol(TargetSheet)
With TargetSheet
Set TargetRange = .Range(.Cells(2, 1), .Cells(LastRow, LastCol))
End With
LastCombinedRow = FindLastRow(CombinedSheet)
With CombinedSheet
Set AddNewRange = .Range(.Cells(LastCombinedRow + 1, 1), _
.Cells(LastCombinedRow + 1 + LastRow, LastCol))
End With
TargetRange.Copy Destination:=AddNewRange
End If
TargetBook.Close SaveChanges:=False
Next Idx
'set up a final range for duplicate removal
LastCombinedRow = FindLastRow(CombinedSheet)
With CombinedSheet
Set FinalRange = .Range(.Cells(1, 1), .Cells(LastCombinedRow, LastCol))
End With
'populate the array for use in the duplicate removal
ReDim RemoveDupesArray(LastCol)
For Idx = 0 To (LastCol - 1)
RemoveDupesArray(Idx) = Idx + 1
Next Idx
FinalRange.RemoveDuplicates Columns:=Evaluate(RemoveDupesArray), Header:=xlYes
'save the results
CombinedFileName = ThisWorkbook.Path & "\Combined_Data"
Application.DisplayAlerts = False
CombinedBook.SaveAs FileName:=CombinedFileName, FileFormat:=51
CombinedBook.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
'prompt user to select files then return the selected fd object
Public Function UserSelectMultipleFiles(DisplayText As String) As FileDialog
Dim usmfDialog As FileDialog
Set usmfDialog = Application.FileDialog(msoFileDialogOpen)
With usmfDialog
.AllowMultiSelect = True
.Title = DisplayText
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Filters.Add ".xlsb files", "*.xlsb"
.Filters.Add ".xlsm files", "*.xlsm"
.Filters.Add ".xls files", "*.xls"
.Filters.Add ".csv files", "*.csv"
.Filters.Add ".txt files", "*.txt"
.Show
End With
Set UserSelectMultipleFiles = usmfDialog
End Function
'identify last row in a worksheet
Public Function FindLastRow(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
FindLastRow = Sheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Else
FindLastRow = 1
End If
End Function
'identify last col in a worksheet
Public Function FindLastCol(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
FindLastCol = Sheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
FindLastCol = 1
End If
End Function
Copying worksheets from multiple workbooks into current workbook
Hi I was wondering if anybody if you guys could help me out?
Im trying to copy multiple workbooks and just save it into only one worksheet.
I have 2000 diffrent workbooks with the diffrent amount of rows, The ammount of cells is the same and it dosent change and they are all at the first sheet in every workbook.
Im new with this kind of stuff so i'm thankfull for all help u can offer, I cant make it work. I'm using excel 2010
This is what I got atm:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = “C:\test\”
MyFile = Dir("test\")
Do While Len(MyFile) > 0
If MyFile = "master.xlsm" Then
Exit Sub
End If
Range(Range("a1"), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Name = "PivotData"
Workbooks.Open (Filepath & MyFile)
Range("A2:AD20").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, 1))
MyFile = Dir
Loop End
Sub
I've re-written your code by applying what I posted in the comment.
Try this out: (I stick with your logic using the DIR function)
Sub test()
Dim MyFile As String, MyFiles As String, FilePath As String
Dim erow As Long
'~~> Put additional variable declaration
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
FilePath = "C:\test\"
MyFiles = "C:\test\*.xlsx"
MyFile = Dir(MyFiles)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Set your declared variables
Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
Set wsMaster = wbMaster.Sheets("Sheet1") 'replace Sheet1 to suit
Do While Len(MyFile) > 0
'Debug.Print MyFile
If MyFile <> "master.xlsm" Then
'~~> Open the file and at the same time, set your variable
Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
Set wsTemp = wbTemp.Sheets(1) 'I used index, you said there is only 1 sheet
'~~> Now directly work on your object
With wsMaster
erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row
'~~> Copy from the file you opened
wsTemp.Range("A2:AD20").Copy 'you said this is fixed as well
'~~> Paste on your master sheet
.Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
End With
'~~> Close the opened file
wbTemp.Close False 'set to false, because we opened it as read-only
Set wsTemp = Nothing
Set wbTemp = Nothing
End If
'~~> Load the new file
MyFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I've commented the code to help you modify it to suit your needs.
I you got stuck again, then just go back here and clearly state your problem.
Try this out:
Option Explicit
Sub CombineDataFiles()
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, _
LastDataRow As Long, LastDataCol As Long, _
HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range
'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1
'prompt user to 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
'error trap - don't allow user to pick more than 2000 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
Exit Sub
End If
'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)
'loop through all 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
'identify row/column boundaries
LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'if this is the first go-round, include the header
If FileIdx = 1 Then
Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
'if this is NOT the first go-round, then skip the header
Else
Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
End If
'copy the data to the outbook
DataRng.Copy OutRng
'close the data book without saving
DataBook.Close False
'update the last outbook row
LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Next FileIdx
'let the user know we're done!
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")
End Sub