Hi kjg
The Code in the attached appears to do as you require. Please note this Code in the Workbook Open Event.
Option Explicit
Private Sub Workbook_Open()
Dim ws As Worksheet, ws1 As Worksheet
Dim LR As Long, LC As Long
Set ws = Sheets(1)
Application.ScreenUpdating = False
If Not Evaluate("ISREF(Lists!A1)") Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
Else
Sheets("Lists").Cells.ClearContents
End If
Set ws1 = Sheets("Lists")
ws1.Range("B1").Value = "Models"
With ws
.Activate
LR = .Range("A" & .Rows.Count).End(xlUp).Row
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
.Range("A2:A" & LR).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ws1.Range("A1"), Unique:=True
ActiveWorkbook.Names.Add Name:="Dates", RefersTo:= _
"=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
.Range(.Cells(2, "E"), .Cells(2, LC)).Copy
ws1.Range("B2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWorkbook.Names.Add Name:="Models", RefersTo:= _
"=OFFSET(Lists!$B$2,0,0,(COUNTA(Lists!$B:$B)-1),1)"
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Bookmarks