I have written a macro, that is crawling through multiple excel files, which are all identical in terms of structure (columns, but row content may differ; there is a "key" though) and matching and copying the data into a master file. But with an increasing number of files the duration of macro execution is growing longer and longer, so maybe someone has a more efficient solution available?
Sub DataCrawler()
On Error GoTo HandleError
Application.ScreenUpdating = False
Dim objectFileSys As Object
Dim objectGetFolder As Object
Dim file As Object
Set objectFileSys = CreateObject("Scripting.FileSystemObject")
Set objectGetFolder = objectFileSys.GetFolder("pathName") ' location of folder with files
Dim counter As Integer
counter = 0
' macro opens one file after another and checks for every key, if data is available
For Each file In objectGetFolder.Files
Dim sourceFiles As Workbook
Set sourceFiles = Workbooks.Open(file.Path, True, True)
Dim lookUp As Range
Dim searchRange As Range
For i = 10 To 342 ' number of rows with key in master file
Set lookUp = Cells(i, 31)
Set searchRange = sourceFiles.Worksheets("tableName").Range("AE:AJ")
' if cell in master file related to the key is empty, copy data
If IsEmpty(Cells(i, 35)) Then
lookUp.Offset(0, 1).Value = Application.VLookup(lookUp, searchRange, 2, False)
lookUp.Offset(0, 2).Value = Application.VLookup(lookUp, searchRange, 3, False)
lookUp.Offset(0, 3).Value = Application.VLookup(lookUp, searchRange, 4, False)
lookUp.Offset(0, 4).Value = Application.VLookup(lookUp, searchRange, 5, False)
lookUp.Offset(0, 5).Value = Application.VLookup(lookUp, searchRange, 6, False)
' if cell in master file related to the key is already filled, skip
Else
End If
Next
sourceFiles.Close False
Set sourceFiles = Nothing
Next
HandleError:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
A single Application.Match() to find the row for the "key", then copying the content as an array would be faster, but it's difficult to say what impact that would have on the overall run time. That would depend on how many files you're opening, and what the performance of that aspect of the process is like.
Sub DataCrawler()
Dim objectFileSys As Object, objectGetFolder As Object
Dim file As Object, searchRange As Range, i As Long
Dim m, wsData As Worksheet, wbSource As Workbook
On Error GoTo HandleError
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsData = ThisWorkbook.Sheets("Lookup") 'for example
Set objectFileSys = CreateObject("Scripting.FileSystemObject")
Set objectGetFolder = objectFileSys.GetFolder("pathName")
For Each file In objectGetFolder.Files
Set wbSource = Workbooks.Open(file.Path, True, True)
Set searchRange = wbSource.Worksheets("tableName").Columns("AE")
For i = 10 To 342 ' number of rows with key in master file
If IsEmpty(wsData.Cells(i, 35)) Then
m = Application.Match(wsData.Cells(i, 31).Value, searchRange, 0)
If Not IsError(m) Then
wsData.Cells(i, 32).Resize(1, 5).Value = _
searchRange.Cells(m).Offset(0, 1).Resize(1, 5).Value
End If
End If
Next
wbSource.Close False
Next file
HandleError:
If Err.Number <> 0 Then MsgBox Err.Description
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Related
I need to make a macro which asks the user to select an excel file, then goes through each column (without headers), identifies the column who values have a length of only 7 and copy it into the original excel where the macro is.
Sub Upload()
InitializeSettings
Dim FindOrdernummer As Range
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", , "Browse for your File & Import")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
OpenBook.Sheets(1).Range("A1:Z70").Find
End If
Application.ScreenUpdating = True
End Sub
I am thinking of making a for loop but i am unable to code the part where it looks through the entire column and not just a particular cell.
Help would be much appreciated on this seemingly simple matter!
Unfortunately you can't select all cells at once that have a value with a length of 7, so you need to go through all the cells in the column to check.
You can do that with a for loop and it would look something like this:
Dim r As Range
Dim col As Range
Dim ws As worksheet
Set worksheet = Application.ActiveSheet
Set r = ws.Range("A1:Z70")
For Each col In r.Columns
Dim copyColumn As Boolean
copyColumn = True 'make sure you reset this variable for every column
For i = 1 To 70
If Len(ws.Cells(i, col.Column).Value) <> 7 Then
copyColumn = False
Exit For
'If one of the cells does not have a value with a length of 7,
'you can stop the loop and continue to the next column
Next
Next i
If copyColumn = True Then
'Copy the column
End If
Next col
This Loop should list all the Value that length is 7.
Option Explicit
Dim MacroWb As Workbook
Sub Upload()
InitializeSettings
Dim FindOrdernummer As Range
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Set MacroWb = ThisWorkbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", , "Browse for your File & Import")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
Call FindValuesWithlengtOfSeven
End If
Application.ScreenUpdating = True
End Sub
Sub FindValuesWithlengtOfSeven()
Dim rng As Range
Dim cel As Range
Dim Occurrence As Long
Occurrence = 1
Set rng = OpenBook.Sheets(1).Range("A1:Z70")
For Each cel In rng
If Len(cel.Value) = 7 Then
'********** Change it to the sheet name you want to put the list "TheNameOfTheSheet"
MacroWb.Sheets("TheNameOfTheSheet").Range("A" & Occurrence).Value = cel.Value
Occurrence = Occurrence + 1
End If
Next cel
Set rng = Nothing
End Sub
Good Day! I have a code that copies all information from some files and inserts it into master file. I would like to modify it. Not to copy it but to sum up.
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range, r as Range
Set Wb = ThisWorkbook
MyDir = "C:\Project\"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
For Each r in Rows
With Worksheets("Sheet1")
r.Rows.Hidden = False
Rws = .Cells(Rows.Count, 12).End(xlUp).Row
Set Rng = Range(.Cells(5, 12), .Cells(Rws, 12))
Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, 12).End(xlUp).Offset(0, 1) 'So here I copy infromation adn insert it.
ActiveWorkbook.Close True
End With
Next
Application.DisplayAlerts = 1
MyFile = Dir()
Loop
I cannot get my head around it. How do i sum up the same information and instead of copying it.
I dont mean sum up all the rows into master file, i would like to sum up same rows from different files into one master file.
Another thing, few files contain hidden rows, mayhaps im doing something wrong but those rows are still being hidden
r.Rows.Hidden = False
does not seem to do the thing.
Any help would be much appreciated
Structure: All files are the same structure-wise, master-file is the same file but without any information in it, just the header. - first 4 rows Column 12 ("L") - is last one has the information i need, or will have i should say. Every Row has an ID that differ it from any other(column 1 - "A"). All documents all very similar, Items in those rows are the same, only difference is the quantity in the last column, which what i need to count. Master file: Row - Item - Quantity from All other files.
You could try this:
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range, r As Range
Set Wb = ThisWorkbook
MyDir = "C:\Project\"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
Dim sWb As Workbook
Set sWb = Workbooks.Open(MyFile)
With sWb.Worksheets("Sheet1")
.Rows.Hidden = False
Rws = .Cells(Rows.Count, 12).End(xlUp).Row
Set rng = Range(.Cells(5, 1), .Cells(Rws, 12))
End With
With Wb.Worksheets("Sheet1")
Dim MatchingColumn As Range
Set MatchingColumn = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
For Each r In rng.Rows
If r.Cells(1, 1).Value2 <> vbNullString Then 'Ignoring empty rows
'We find the row where the Ids matche
Dim MatchingRowNb As Long
MatchingRowNb = Application.Match(r.Cells(1, 1).Value2, MatchingColumn, False)
'We add the current value in the cell with the new value comming from the other file
.Cells(4 + MatchingRowNb, 12).Value2 = .Cells(4 + MatchingRowNb, 12).Value2 + r.Cells(1, 12).Value2
End If
Next
End With
sWb.Close SaveChanges:=True
Application.DisplayAlerts = True
MyFile = Dir()
Loop
I'm very new to VBA and I'm working on a project where I've got multiple Excel files in a folder, each structured the same way, and I want to loop through each of them, search for specific terms in each single file, copy it, and paste it to the master-file in a specific way.
I already got everything except pasting it the right way:
Every term it finds in a source-file should be posted to the next empty column in the master file and for each new source-file the loop goes through, it should post the stuff it finds to a new row in the master file.
Below is what I've already got.
Private Const sPath As String = "F:\ExamplePath"
Sub LoopThroughFiles()
Dim sFile As String 'File Name
Dim sExt As String 'File extension
sExt = "xlsx"
'loop through each file name and open it if the extension is correct
sFile = Dir(sPath)
Do Until sFile = ""
If Right(sFile, 4) = sExt Then GetInfo sFile
sFile = Dir
Loop
End Sub
Private Sub GetInfo(sFile As String)
Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String
On Error GoTo errHandle
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbFrom = Workbooks.Open(sPath & sFile)
'finds Search-Term
With wbFrom.Sheets(1).Cells
Set cl = .Find("necrosis_left", After:=.Range("C2"), LookIn:=xlValues)
If Not cl Is Nothing Then
strAddress = cl.Address
cl.Select
Selection.Copy
iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
End If
End With
'finds other Search-Term
With wbFrom.Sheets(1).Cells
Set cl = .Find("necrosis_right", After:=.Range("C2"), LookIn:=xlValues)
If Not cl Is Nothing Then
strAddress = cl.Address
cl.Select
Selection.Copy
iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
End If
End With
'many more search terms
wbFrom.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Set wbFrom = Nothing
Exit Sub
errHandle:
MsgBox Err.Description
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
So I do know, that my problem is located here:
iRow = Me.Range("A" & Rows.Count).End(xlUp).Row + 1 'Get an empty row in this workbook
Me.Range("A" & iRow).PasteSpecial xlPasteAll 'past copied cells
But I can't quite figure out how it posts to an empty column instead of an empty row, not to speak of how to make it go down a row in the master file for each new source file.
Found the answer to my own question!
The first step was to replace the "paste-line" above with the following:
Me.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll
This pastes every copied cell to the next empty column in line 1.
To start a new line for every source-file the loop goes through, a public variable had to be declared, which counted up each iteration. The final code looks like this:
Private Const sPath As String = 'enter your path
Public Zeile As Integer 'public variable
Sub LoopThroughFiles()
Dim sFile As String 'File Name
Dim sExt As String 'File extension you wish to open
Zeile = 1 'important for not start pasting in row 0 (which is impossible)
sExt = "xlsx" 'Change this if extension is different
'loop through each file name and open it if the extension is correct
sFile = Dir(sPath)
Do Until sFile = ""
If Right(sFile, 4) = sExt Then GetInfo sFile
sFile = Dir
Zeile = Zeile + 1 'goes up each iteration
Loop
End Sub
Private Sub GetInfo(sFile As String)
Dim wbFrom As Workbook 'workbook to copy the data from
Dim iRow As Integer 'row number of next empty row
Dim cl As Range
Dim strAddress As String
On Error GoTo errHandle
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbFrom = Workbooks.Open(sPath & sFile)
'copy the following block for each term you want to search for
With wbFrom.Sheets(1).Cells
Set cl = .Find("searchterm", After:=.Range("C2"), LookIn:=xlValues)
If Not cl Is Nothing Then
strAddress = cl.Address
cl.Select
Selection.Copy
Me.Cells(Zeile, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteAll 'the rows are controlled via the public variable
End If
End With
wbFrom.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Set wbFrom = Nothing
Exit Sub
errHandle:
MsgBox Err.Description
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The result loops through all files of a folder, searches for a specific term and pastes each result in the next empty column of the master file, but starts a new row for each source file.
Thanks though!
The code below is able to loop my files in the folder and add the file names into the dictionary, however when i add my extraction code in, its supposed to extract data from every single file in the folder into one excel sheet and for file 1 should be in range A2:M2, file 2 in range A3:M3 and so on. but despite being able to extract data from every file, everytime the first file will be written to range A2:M2 but as it continues to the next file, it will overwrite data from first file onto the same range A2:M2 even though file 2 data should be written into A3:M3 and file 3 into A4:M4 and so on.
May i know how i can fix this issue, thank you so much.
Public Dict As Object
Sub EEE()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Dim oFSO As Object, oFolder As Object, ofile As Object
Set oFSO = CreateObject("Scripting.fileSystemObject")
Set oFolder = oFSO.GetFolder("C:\Users\Desktop\")
If Dict Is Nothing Then
Set Dict = CreateObject("Scripting.Dictionary")
Dict.Add Key:="filename", Item:=ofile
End If
For Each ofile In oFolder.Files
If Not Dict.Exists(oFSO.GetBaseName(ofile)) Then
' start of extraction code
Dim a As Range
Dim wkbData As Workbook
Set wkbData = Workbooks.Open(ofile.path)
Dim wksData As Worksheet
ActiveSheet.Name = "Book1"
Set wksData = wkbData.Worksheets("Book1") ' -> Assume this file has only 1 worksheet
Dim LastRow As Long
LastRow = wks.Range("A" & wks.Rows.count).End(xlUp).row + 1
wks.Cells(LastRow, 6).value = ofile.Name
Set a = wksData.Columns("A:A").Find(" test1234 : ", LookIn:=xlValues)
If Not a Is Nothing Then
wks.Cells(LastRow, 1) = Split(a.value, ":")(1)
End If
wkbData.Close False
' end of extraction code
Range("A:M").EntireColumn.AutoFit
Range("A1").AutoFilter
Debug.Print "A: " & oFSO.GetBaseName(ofile)
Dict.Add oFSO.GetBaseName(ofile), 1
Else
'skip
Debug.Print "E: " & oFSO.GetBaseName(ofile)
End If
Next ofile
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
End Sub
Following from my comment above:
Dim LastRow As Long
LastRow = wks.Range("A" & wks.Rows.count).End(xlUp).row + 1 '<< this can be outside your loop
For Each ofile In oFolder.Files
If Not Dict.Exists(oFSO.GetBaseName(ofile)) Then
Dim a As Range
Dim wkbData As Workbook
Set wkbData = Workbooks.Open(ofile.path)
Dim wksData As Worksheet
Set wksData = wkbData.Worksheets(1) ' -> Assume this file has only 1 worksheet
wks.Cells(LastRow, 6).value = ofile.Name
Set a = wksData.Columns("A:A").Find(" test1234 : ", LookIn:=xlValues)
If Not a Is Nothing Then
wks.Cells(LastRow, 1) = Split(a.value, ":")(1)
Else
wks.Cells(LastRow, 1) = "No Data!"
End If
wkbData.Close False
Debug.Print "A: " & oFSO.GetBaseName(ofile)
Dict.Add oFSO.GetBaseName(ofile), 1
LastRow = LastRow +1 '<< increment the row
Else
Debug.Print "E: " & oFSO.GetBaseName(ofile)
End If
Next ofile
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