Sub Extract()
Dim Sh As Range
Dim Cel As Range
Dim Derlig As Long
Application.ScreenUpdating = False
Derlig = [A1].End(xlDown).Row
Rows(Derlig + 1 & ":65000").Delete
Range("A1:J" & Derlig).Name = "base"
[M1] = [A1]: [N1] = [J1]
Range("base").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"M1:N1"), Unique:=True
For Each Cel In Range("M2:M" & [M65000].End(xlUp).Row)
If IsNumeric(Cel.Offset(0, 1).Value) Then
[M2] = Cel.Value: [N2] = Cel.Offset(0, 1).Value
Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"M1:N2"), CopyToRange:=Cells(Derlig + 2, 1), Unique:=False
Rows(Derlig + 2).ClearContents
Cells(Derlig + 2, 1).Value = "PERIOD " & [N2]
Cells(Derlig + 2, 2).Value = "PROFILE " & [M2]
Cells(Derlig + 2, 3).Value = "TRI PAR REGION"
Derlig = [A65000].End(xlUp).Row
End If
Next Cel
Columns("M:N").Delete
End Sub
Sub Extract()
Dim Sh As Range
Dim Cel As Range
Dim Derlig As Long, DerLig2 As Long
Application.ScreenUpdating = False
Derlig = [A1].End(xlDown).Row
Range("A1:O" & Derlig).Name = "base"
[P1] = [A1]: [Q1] = [O1]
Range("base").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"P1:Q1"), Unique:=True
Range("P1:Q" & [P65000].End(xlUp).Row).Sort Key1:=Range("P2"), Order1:=xlAscending, Key2:=Range("Q2") _
, Order2:=xlAscending, Header:=xlGuess
With Sheets("CAZ TABLE")
.Cells.Clear
For Each Cel In Range("P2:P" & [P65000].End(xlUp).Row)
If IsNumeric(Cel.Offset(0, 1).Value) Then
[P2] = Cel.Value: [Q2] = Cel.Offset(0, 1).Value
DerLig2 = .[A65000].End(xlUp).Row + 2
Range("B1,D1:N1").Copy .Cells(DerLig2 + 1, 1)
Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"P1:Q2"), CopyToRange:=.Range(.Cells(DerLig2 + 1, 1), .Cells(DerLig2 + 1, 12)), Unique:=False
.Cells(DerLig2, 1).Value = "PROFILE " & [P2]
.Cells(DerLig2, 2).Value = "PERIOD " & [Q2]
With .Range(.Cells(DerLig2, 1), .Cells(DerLig2, 2))
.Font.Bold = True
End With
End If
Next Cel
.Cells.EntireColumn.AutoFit
End With
Columns("P:Q").Delete
End Sub
Range("A1:O" & Derlig).Name = "base"
Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"P1:Q2"), CopyToRange:=.Range(.Cells(DerLig2 + 1, 1), .Cells(DerLig2 + 1, 12)), Unique:=False