The VBA code below will pull data from every workbook located in a designated folder and put it into a master workbook. The workbooks that have the desired data are called the source workbooks. Each source workbook will be opened one at a time. Data will be copied from the source workbook based on certain conditions and put into the master workbook. After data has been pulled, the source workbook will be closed.
A handful of parameters in this code will need to be changed for your application. The first is the pathway and name of the folder that has the source workbooks. In the code below this pathway and folder name is "C:\Users\sfost\Desktop\New folder\". The second is the name of the worksheet in each source workbook. The name needs to be the same and is "Sheet1" in the code below. The third is the range of the data that will be copied from each source workbook. In the code below the range is "Ax:Ex". Finally, the conditions that determine what data in the source workbook that will be pulled. Again, all of these parameters will need to be adjusted for your application. Additional code can be added if sheet names or ranges change for each source workbook.
Please contact us if you have any questions.
Sub DataPull_1()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim TWB As Workbook
Dim SH2 As Worksheet
Dim SCR As Workbook
Set TWB = ThisWorkbook
Set SH2 = TWB.Worksheets("Sheet2")
Dim Source As String
Dim StrFile As String
Dim LR_SH2 As Long
Dim LR_SCR As Long
Dim n As Long
' Clearing contents currently in the data pull workbook.
LR_SH2 = SH2.Cells(Rows.Count, "A").End(xlUp).Row
If LR_SH2 > 1 Then
SH2.Range("A2:E" & LR_SH2).ClearContents
End If
' Settnig the folder pathway.
Source = "C:\Users\sfost\Desktop\New folder\"
StrFile = Dir(Source)
n = 2
' Pull data from every file.
Do While Len(StrFile) > 0
' Assuming the data pull workbook is in the same file as the workbooks data will be pulled from.
If StrFile = TWB.Name Then
GoTo NextFile
End If
' Opening workbook.
Set SCR = Workbooks.Open(Filename:=Source & StrFile, ReadOnly:=True)
LR_SCR = SCR.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Copying data from workbook if conditions are met.
For A = 2 To LR_SCR
If SCR.Worksheets("Sheet1").Cells(A, "C").Value = "High" Then
SH2.Range("A" & n & ":E" & n) = SCR.Worksheets("Sheet1").Range("A" & A & ":E" & A).Value
n = n + 1
End If
Next A
SCR.Close SaveChanges:=False
NextFile:
StrFile = Dir()
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Copyright © 2024 sheetsfreaks - All Rights Reserved.
Powered by GoDaddy
We use cookies to analyze website traffic and optimize your website experience. By accepting our use of cookies, your data will be aggregated with all other user data.