Sub fil_Profname()
  Application.ScreenUpdating = False
  Dim p As Worksheet, T As Worksheet, G As Worksheet
  Dim x%, xx%, m%, how_many%, r%, i%, y%, mun%: num = 1
  Dim resl As Range, F_rg As Range
  Dim Mth As Range, arr(), cel As Range
  Dim D_arr()
  Set p = Sheets("P"): Set T = Sheets("T")
  Set G = Sheets("GHIAB")
  Set resl = G.Range("a5").CurrentRegion
   
   r = resl.Rows.Count
 If r > 1 Then resl.Offset(1).Resize(r - 1).Clear
    x = 4: m = 6
 Do Until p.Range("a" & x) = vbNullString
 '======================================
         how_many = Application.CountIf(p.Range("D" & x).Resize(, 500), "Ok")
          If how_many = 0 Then GoTo Next_x
           Set Mth = G.Range("P12:P23").Find(G.Range("P5")).Offset(, 1)
           first = Application.Match(Mth, p.Cells(500, "d").Resize(, 250), 0) + 3
           y = Application.CountIf(p.Rows(500), Mth)

             For Each cel In p.Cells(3, first).Resize(, y)
               If Month(cel) = Mth And UCase(cel.Offset(x - 3)) = "OK" Then
                ReDim Preserve arr(1 To num)
                ReDim Preserve D_arr(1 To num)
                arr(num) = CDate(cel)
                D_arr(num) = cel.Offset(-1)
                num = num + 1
               End If
             Next
             If num > 1 Then
              G.Cells(m, 1).Resize(num - 1) = Application.Transpose(arr)
              G.Cells(m, 2).Resize(num - 1) = Application.Transpose(D_arr)
                For i = 1 To num - 1
                 G.Cells(m + i - 1, 3) = p.Cells(x, 1)
                 G.Cells(m + i - 1, 4) = p.Cells(x, 2)
                 G.Cells(m + i - 1, 5) = p.Cells(x, 3)
                 
                Next
                      
                m = m + num - 1
             End If
          Erase arr: Erase D_arr: num = 1
Next_x:
          x = x + 1

  Loop
  
 Set resl = G.Range("a5").CurrentRegion
 r = resl.Rows.Count
 If r = 1 Then Exit Sub
  Set resl = resl.Offset(1).Resize(r - 1)

  With resl
   .InsertIndent 1
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
  End With
  MADDA
  Application.ScreenUpdating = True
End Sub
'================================
Sub MADDA()

  Dim T As Worksheet, G As Worksheet
  Dim x%, xx%, m%, r1%
  Dim F_rg As Range
  
  Set T = Sheets("T")
  Set G = Sheets("GHIAB")

  x = 6: m = 6
Do Until G.Range("A" & x) = vbNullString
     xx = T.Rows(1).Find(G.Range("B" & x)).Column
      Set F_rg = T.Columns(1).Find(G.Range("C" & x), lookat:=1)
       If F_rg Is Nothing Then GoTo Next_x
       r1 = F_rg.Row
       G.Cells(m, 6).Resize(, 8).Value = _
       T.Cells(r1, xx).Resize(, 8).Value
       m = m + 1
Next_x:
    x = x + 1
Loop
End Sub