Transfer rows of data from multiple workbooks to master workbook based on value in row
Hello all,
I'm a bit of a self taught excel user, so my VBA knowledge is a bit limited. I have created timesheets for employees that work in our shop. Our company manufactures products for different industries, such as mining, wind power generation, general industrial applications, and so forth. I modified some time sheet templates I found for excel to accommodate our company's actions. Each employee has their own workbook, in which the months are separated into different worksheets. Each sheet is divided further into weeks and in each weekly section the areas of information are divided. I have attached an example worksheet for reference.
There are 7 workbooks (one for each employee), each with 12 sheets (one for each month)that I need to reference. I want to create a master sheet that will pull information from everyone's timesheets if they worked on a particular job. In other words, I would like to type a job number into a cell in the master sheet, then have excel look through everyone's timesheets and pull over only the rows of information that contain that job number and populate those rows in the master sheet. From there I can further manipulate the data to get further information for a particular job.
I have been searching and have only gotten limited advice on this subject. I was hoping to accomplish this without VBA through a combination of formulas, but I have failed in that field. Please let me know if this is possible. Thank you in advance for any help.
| Attachment | Size |
|---|---|
| Joe Smith.xlsx | 370.38 KB |
Reply expected
I will appreciate if you take time to reply
Extract Data from Sheets & WorkBks And Post in another WorkBk
Since so far no one has replied, I post my suggestion here. Try this and if necessary, change the code as per your need:
Private Sub cmdExtractData_Click()
'http://excelexperts.com/transfer-rows-data-multiple-workbooks-master-workbook-based-value-row
Dim MstrBk, DataWBk As Workbook
Dim DataWBkName As String
Dim MstrWBkName As String
Dim SrcShtName As String
Dim FylsPath As String
Dim DataWBkPathAndName As String
Dim MstrWBkPathAndName As String
Dim LstRcrd As Long
Dim LstRow As Long
Dim LstRecNum As Long
Dim AllWKBks As String
Dim AllWKShts As String
Dim EachWKBk() As String
Dim EachWKSht() As String
Dim SrchVal As Range
Dim rSrchJobNum As Range 'checking whether number is available
Dim SelRange As Range
Dim FiltRng As Range
FylsPath = "d:\VBCode\"
ThisWorkbook.Sheets(1).Activate
Set SrchVal = Range("a1") 'Job Number to search
MstrWBkName = "MstrWkBk.xls"
MstrWBkPathAndName = FylsPath & MstrWBkName
If AlreadyOpen(MstrWBkName) = False Then
Workbooks.Open MstrWBkPathAndName
End If
Set MstrBk = Workbooks(MstrWBkName)
MstrBk.Activate
Worksheets("MasterSheet").Cells.Delete
LstRcrd = Cells(Rows.Count, "D").End(xlUp).Row
AllWKBks = "Joe Smith.xlsx, WBk2.xls, WBk3.xls"
AllWKShts = "January, February, March"
EachWKBk = Split(AllWKBks, ",")
EachWKSht = Split(AllWKShts, ",")
Dim VaryWrkBk As Integer
Dim VaryMnth As Integer
Dim SrcPrevLastRecNum As Long 'Last Record Number of Source Sheet
For VaryWrkBk = 0 To UBound(EachWKBk)
DataWBkName = Trim(EachWKBk(VaryWrkBk))
DataWBkPathAndName = FylsPath & DataWBkName
'Following code runs a function instead of this : Workbooks.Open Filename:=DataWBkPathAndName
If AlreadyOpen(DataWBkName) = False Then
Workbooks.Open DataWBkPathAndName
End If
Set DataWBk = Workbooks(DataWBkName)
DataWBk.Activate
For VaryMnth = 0 To UBound(EachWKSht)
DataWBk.Activate
SrcShtName = Trim(EachWKSht(VaryMnth))
Sheets(SrcShtName).Select
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
LstRow = Cells(Rows.Count, "D").End(xlUp).Row
SrcPrevLastRecNum = LstRow
Range("D2").Select 'in job card
Set SelRange = ActiveSheet.Range("D1:D" & Trim(Str(LstRow))) 'D has Job Numbers.
SelRange.AutoFilter
SelRange.AutoFilter Field:=1, Criteria1:=SrchVal 'field number is from the one set in SelRange
LstRecNum = Cells(Rows.Count, "D").End(xlUp).Row
Set FiltRng = Range("A1:M" & Trim(Str(LstRecNum)))
MstrBk.Activate
LstRcrd = Cells(Rows.Count, "D").End(xlUp).Row
If LstRcrd = 1 Then
LstRcrd = 0
End If
FiltRng.Copy Destination:=MstrBk.Sheets("MasterSheet").Range("A" & Trim(Str(LstRcrd + 1)))
Set FiltRng = Nothing
SelRange.AutoFilter
Next 'VaryMnth = 0 To UBound(EachWKSht)
Next 'VaryWrkBk = 0 To UBound(EachWKBk)
Set MstrBk = Nothing
Set DataWBk = Nothing
End Sub
Copy the following Function in a Module:
Function AlreadyOpen(sFname As String) As Boolean 'http://excel.tips.net/T003104_Checking_if_a_Workbook_is_Already_Open.html
Dim wkb As Workbook
On Error Resume Next
Set wkb = Workbooks(sFname)
AlreadyOpen = Not wkb Is Nothing
Set wkb = Nothing
End Function