Function ВПРМН(iVal, sRng$, iClmn)
'iVal - искомое значение
'sRng$ - адрес диапазона для поиска значения, текст вида "C:F".
'      Поиск осуществляется в первом столбце, так же как и в ВПР()
'iClmn - номер столбца из которого возвращается значение
'Всегда ищется точное совпадение
Dim iWb As Workbook
Dim iSh As Worksheet
Dim iRng As Range
Dim arrDay()
On Error Resume Next
Set iWb = Application.Caller.Parent.Parent
ReDim arrDay(1 To iWb.Worksheets.Count)
For Each iSh In iWb.Worksheets
  If IsDate(CDate(iSh.Name)) Then
    If Err = 0 Then
      I = I + 1
      arrDay(I) = CDbl(CDate(iSh.Name))
    End If
    Err = 0
  End If
Next
ReDim Preserve arrDay(1 To I)
For I = 1 To UBound(arrDay)
  Set iSh = iWb.Worksheets(Format(CDate(Application.WorksheetFunction.Large(arrDay, I)), "dd.mm.yy"))
  Set iRng = Intersect(iSh.UsedRange, iSh.Range(sRng))
  ВПРМН = Application.WorksheetFunction.VLookup(iVal, iRng, iClmn, 0)
  If Not IsEmpty(ВПРМН) Then Exit Function
Next
If IsEmpty(ВПРМН) Then ВПРМН = CVErr(xlErrNA)
End Function

Function ВПРМН(iVal, sRng$, iClmn)
'iVal - искомое значение
'sRng$ - адрес диапазона для поиска значения, текст вида "C:F".
'      Поиск осуществляется в первом столбце, так же как и в ВПР()
'iClmn - номер столбца из которого возвращается значение
'Всегда ищется точное совпадение
Dim iWb As Workbook
Dim iSh As Worksheet
Dim iRng As Range
Dim arrDay()
On Error Resume Next
Set iWb = Application.Caller.Parent.Parent
ReDim arrDay(1 To iWb.Worksheets.Count)
For Each iSh In iWb.Worksheets
  If iSh.Name Like "день*" Then
    I = I + 1
    arrDay(I) = Val(Split(iSh.Name, " ")(1))
  End If
Next
ReDim Preserve arrDay(1 To I)
For I = 1 To UBound(arrDay)
  For Each iSh In iWb.Worksheets
    If iSh.Name Like "день*" & Application.WorksheetFunction.Large(arrDay, I) Then
      Set iRng = Intersect(iSh.UsedRange, iSh.Range(sRng))
      ВПРМН = Application.WorksheetFunction.VLookup(iVal, iRng, iClmn, 0)
      If Not IsEmpty(ВПРМН) Then Exit Function
    End If
  Next
Next
If IsEmpty(ВПРМН) Then ВПРМН = CVErr(xlErrNA)
End Function

Sub Разделить_столбец_по_книгам_MAC()
Const column = 7 'номер столбца, по которому будет происходить разделение.'
Const head = True
Dim iCol As New Collection
Dim I&, iKey, iTmp

Set wbAct = ActiveWorkbook
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).column
arr = Range("A1", Cells(lr, lc)).Value
If head Then fr = 2 Else fr = 1
For I = fr To UBound(arr)
  If Application.Trim(arr(I, column)) <> "" Then
    iKey = Application.Trim(arr(I, column))
    If KeyExists(iKey, iCol) Then
      iTmp(1) = iCol.Item(iKey)(1) & "|" & I: iTmp(2) = iKey
      iCol.Remove (iKey)
    Else
      ReDim iTmp(1 To 2)
      iTmp(1) = I: iTmp(2) = iKey
    End If
    iCol.Add iTmp, iKey
  End If
Next
 
'Result - название папки с результатами'
iPath = wbAct.Path & Application.PathSeparator & "Result" & Application.PathSeparator
If Dir(iPath, vbDirectory) = "" Then MkDir iPath
 
Set Rng = Nothing
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For I = 1 To iCol.Count
rrs = Split(iCol.Item(I)(1), "|")
    If head Then Set Rng = Rows(1)
    For Each rr In rrs
        If Not Rng Is Nothing Then Set Rng = Union(Rows(rr), Rng) Else Set Rng = Rows(rr)
    Next
    Set wb = Workbooks.Add(1)
    Set sh = wb.Sheets(1)
    Rng.Copy
    With sh.[A1]
      .PasteSpecial xlPasteColumnWidths
      .PasteSpecial xlPasteAll
      .Select
    End With
    Set Rng = Nothing
    wb.SaveAs iPath & Replace_symbols(iCol(I)(2)) & ".xlsx", xlOpenXMLWorkbook
    wb.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

'Замена запрещённых символов в имени файла или папки'
Private Function Replace_symbols(ByVal txt As String) As String
    St$ = "\\/~!@#$%^&*=|`'"""
    For I% = 1 To Len(St$)
        txt = Replace(txt, Mid(St$, I, 1), "_")
    Next
    Replace_symbols = txt
End Function

'Проверка наличия ключа в коллекции
Private Function KeyExists(ByVal key$, ByRef container As Collection) As Boolean
  On Error Resume Next
  Dim temp As Variant
  temp = container.Item(key)
  KeyExists = IIf(IsEmpty(temp), False, True)
  On Error GoTo 0
End Function