Возврат текста при поиске данных

Question

У меня есть таблица, которая выглядит следующим образом:

 
Name  Task    Date 
Mike  Go to the beach 10/1/13 
Mike  Go Shopping  10/2/13 
Mike  Go to work  10/3/13 
Bill  Go Hiking   10/1/13 
Bill  Go to work  10/3/13

Я пытаюсь построить еще одну вкладку в таблицу, которая будет смотреть на вкладке данных и возвращает текстовое значение соответствия, когда строк и столбцов.

Я пытаюсь использовать формулу для создания типа сводной таблицы.

Результаты должны выглядеть следующим образом:

 
Name 10/1/13   10/2/13  10/3/13 
Mike Go to the beach Go shopping Go to work 
Bill Go Hiking  *Blank*  Go to work

Я попытался отправить изображения, но не мог, так как это мой первый пост. Надеюсь, вы поймете, что я прошу.

Answer 1

Я не эксперт в сводных таблицах, я сделал это глупо, но работает. Предположения:

1) Источник данных всегда на «Лист1» с этими 3 заголовками столбцов

2) В «Лист2» ​​будет использоваться для хранения отсортированных данных

Sub SO_19105503() 
    Const NameCol As Long = 1 
    Const TaskCol As Long = 2 
    Const DateCol As Long = 3 

    Dim oShSrc As Worksheet, oShTgt As Worksheet, R As Long, C As Long 
    Dim aNames As Variant, aDates As Variant 
    Dim lNames As Long, lDates As Long 
    Dim oRng As Range, oArea As Range 

    Set oShSrc = ThisWorkbook.Worksheets("Sheet1") ' Source worksheet with original data 
    oShSrc.Copy Before:=oShSrc 
    Set oShSrc = ThisWorkbook.Worksheets("Sheet1 (2)") ' Copy of Source worksheet 
    Set oShTgt = ThisWorkbook.Worksheets("Sheet2") ' Target worksheet to store sorted data 
    oShSrc.AutoFilterMode = False 
    ' Get unique names (sorted) in column A 
    aNames = Array() 
    lNames = 0 
    R = 1 
    oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, NameCol), Header:=xlYes 
    Do 
     R = R + 1 
     If Not IsEmpty(oShSrc.Cells(R, NameCol)) And oShSrc.Cells(R, NameCol).Value <> oShSrc.Cells(R - 1, NameCol).Value Then 
      ReDim Preserve aNames(lNames) 
      aNames(lNames) = oShSrc.Cells(R, NameCol).Value 
      lNames = lNames + 1 
     End If 
    Loop Until IsEmpty(oShSrc.Cells(R, NameCol)) 
    ' Get unique dates (sorted) in column C 
    aDates = Array() 
    lDates = 0 
    R = 1 
    oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, DateCol), Header:=xlYes 
    Do 
     R = R + 1 
     If Not IsEmpty(oShSrc.Cells(R, DateCol)) And oShSrc.Cells(R, DateCol).Value <> oShSrc.Cells(R - 1, DateCol).Value Then 
      ReDim Preserve aDates(lDates) 
      aDates(lDates) = oShSrc.Cells(R, DateCol).Value 
      lDates = lDates + 1 
     End If 
    Loop Until IsEmpty(oShSrc.Cells(R, DateCol)) 
    ' Prepare and put data to Target sheet 
    oShTgt.Range("A1").Value = oShSrc.Range("A1").Value ' Name 
    ' Insert Dates (start from column B on Row 1) 
    For C = 0 To lDates - 1 
     oShTgt.Cells(1, C + 2).Value = aDates(C) 
    Next 
    ' Insert Names (start from Row 2 on Column A) 
    For R = 0 To lNames - 1 
     oShTgt.Cells(R + 2, 1).Value = aNames(R) 
    Next 
    ' Reprocess the source data with Autofilter 
    For R = 0 To lNames - 1 
     oShSrc.AutoFilterMode = False ' Remove AutoFilter before apply 
     ' Apply AutoFilter with Criteria of R'th entry in array aNames 
     oShSrc.UsedRange.AutoFilter Field:=1, Criteria1:="=" & aNames(R) 
     ' Go through Ranges in each Area 
     For Each oArea In oShSrc.Cells.SpecialCells(xlCellTypeVisible).Areas 
      For Each oRng In oArea.Rows 
       ' Stop checking if row is more than used 
       If oRng.Row > oShSrc.UsedRange.Rows.count Then 
        Exit For 
       End If 
       ' Check only if the row is below the header 
       If oRng.Row > 1 Then 
        For C = 0 To lDates - 1 
         ' Find the matching date and put the "Task" value 
         If oShSrc.Cells(oRng.Row, DateCol).Value = aDates(C) Then 
          oShTgt.Cells(R + 2, C + 2).Value = oShSrc.Cells(oRng.Row, TaskCol).Value 
          Exit For 
         End If 
        Next C 
       End If 
      Next oRng 
     Next oArea 
    Next R 
    Application.DisplayAlerts = False 
    oShSrc.Delete ' Delete the temporary data source sheet 
    Application.DisplayAlerts = True 
    Set oShSrc = Nothing 
    Set oShTgt = Nothing 
End Sub 

Скриншоты - Источник данных/Результат :