Hi Spi
This Code is in the attached. It assumes the attached workbook is in the same folder as your Master File and Report Files. It further assumes that a Report File exists for each Report Name in the Master File. Let me know of issues...
Option Explicit
Sub Extract_Data()
Dim wbSource As Workbook, wbTarget As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim lrSource As Long, lrTArget As Long
Dim myPath As String
Dim myCol As Long
Dim Rng As Range, cel As Range
Dim x As Long, i As Long, j As Long, k As Long
Dim Headers As Variant
myPath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
If Not IsFileOpen(myPath & "Master File.xlsx") Then
Workbooks.Open myPath & "Master File.xlsx"
End If
Set wbSource = Workbooks("Master File.xlsx")
Set wsSource = wbSource.Sheets("Sheet1")
With wbSource
.Activate
If Not Evaluate("ISREF(Lists!A1)") Then
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = "Lists"
Else
.Sheets("Lists").Cells.ClearContents
End If
With wsSource
lrSource = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
.Range("A1:B" & lrSource).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=wbSource.Sheets("Lists").Range("A1"), Unique:=True
wbSource.Names.Add Name:="Reports", RefersTo:= _
"=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
.AutoFilterMode = False
For Each cel In Sheets("Lists").Range("Reports")
.Range("A1:A" & lrSource).AutoFilter Field:=1, Criteria1:=cel.Value
Set Rng = .AutoFilter.Range
x = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If x >= 1 Then
Set wbTarget = Workbooks.Open(myPath & cel.Value & ".xlsx")
Set wsTarget = wbTarget.Sheets(cel.Offset(0, 1).Value)
With wsTarget
lrTArget = .Range("A4").End(xlDown).Offset(1, 0).Row
If lrTArget = 7 Then lrTArget = 5
.Range("A" & lrTArget).Resize(x, 1).EntireRow.Insert
Headers = Application.WorksheetFunction.Transpose(wsTarget.Range("A4:U4").Value)
k = 1
For i = 1 To 1
For j = LBound(Headers) To UBound(Headers)
Debug.Print Headers(j, i)
With wsSource
myCol = WorksheetFunction.Match(Headers(j, i), .Rows("1:1"), 0)
.Range(.Cells(2, myCol), .Cells(lrSource, myCol)).SpecialCells(xlCellTypeVisible).Copy
End With
Range(Cells(lrTArget, k), Cells(lrTArget, k)).PasteSpecial
Application.CutCopyMode = False
k = k + 1
Next j
Next i
End With
End If
wbTarget.Close True
Next cel
.AutoFilterMode = False
End With
End With
Application.ScreenUpdating = True
End Sub
' From http://www.vbaexpress.com/kb/getarticle.php?kb_id=468
Function IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
LinkBack URL
About LinkBacks
In your greatness, remain humble! 
Register To Reply
Bookmarks