Антон Федорян

Вот сам файлик

Как добавить календарь

Код процедуры клика по дате

Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
    Dim i, col As Integer
    i = 1
    col = 1 ''' номер ячейки с датами '''
    While (Cells(i, col) <> "")
        Rows(i).Select
        If Cells(i, col) <> DateClicked Then
            Selection.EntireRow.Hidden = True
        Else
            Selection.EntireRow.Hidden = False
        End If
        i = i + 1
    Wend
End Sub

Возможно. Загуглить для начала тоже не проблема.

Нужен именно Excel? Попробуйте Libre Office, намного удобнее.
Сохраняет в нужной кодировке по выбору и с любым разделителем.
Открывает также без проблем.

Достаточно просто и с формулами. Вот что получилось:



Теперь по ячейкам:

Для Year:

=ЕСЛИОШИБКА(ЕСЛИ(ПОИСК($D$1;A2;1)>0;ЕСЛИ((ДЛСТР(A2)-ДЛСТР(ПОДСТАВИТЬ(A2;":";"")))=0;ПСТР(B2;1;ДЛСТР(B2));ПСТР(B2;1;ПОИСК(":";B2;1)-1));"NULL");"NULL")

Для Storey:

=ЕСЛИОШИБКА(ЕСЛИ(ПОИСК($E$1;A2;1)>0;ЕСЛИ(ДЛСТР(A2)=(ЕСЛИ(D2="NULL";0;5)+6);1;ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1))+1;ПОИСК(":";B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1))+1)-((ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1))+1)));"NULL");"NULL")

Для Area:

=ЕСЛИОШИБКА(ЕСЛИ(ПОИСК($F$1;A2;1)>0;ЕСЛИ(ДЛСТР(A2)=(ЕСЛИ(D2="NULL";0;5)+ЕСЛИ(E2="NULL";0;7)+4);ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1))+1;ДЛСТР(B2)-(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)));ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1))+1;ПОИСК(":";B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1))+1)-((ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1))+1)));"NULL");"NULL")

Для Condition:

=ЕСЛИОШИБКА(ЕСЛИ(ПОИСК($G$1;A2;1)>0;ЕСЛИ(ДЛСТР(A2)=(ЕСЛИ(D2="NULL";0;5)+ЕСЛИ(E2="NULL";0;7)+ЕСЛИ(F2="NULL";0;5)+9);ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1))+1;ДЛСТР(B2)-(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)));ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1))+1;    ПОИСК(":";B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1))+1)-((ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1))+1) ));"NULL");"NULL")

Для Type:

=ЕСЛИОШИБКА(ЕСЛИ(ПОИСК($H$1;A2;1)>0;ЕСЛИ(ДЛСТР(A2)=(ЕСЛИ(D2="NULL";0;5)+ЕСЛИ(E2="NULL";0;7)+ЕСЛИ(F2="NULL";0;5)+ЕСЛИ(G2="NULL";0;10)+4);ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)+ЕСЛИ(G2="NULL";0;ДЛСТР(G2)+1))+1;ДЛСТР(B2)-(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)+ЕСЛИ(G2="NULL";0;ДЛСТР(G2)+1)));ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)+ЕСЛИ(G2="NULL";0;ДЛСТР(G2)+1))+1;    ПОИСК(":";B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)+ЕСЛИ(G2="NULL";0;ДЛСТР(G2)+1))+1)-((ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)+ЕСЛИ(G2="NULL";0;ДЛСТР(G2)+1))+1) ));"NULL");"NULL")

Для Name:

=ЕСЛИОШИБКА(ЕСЛИ(ПОИСК($I$1;A2;1)>0;ПСТР(B2;(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)+ЕСЛИ(G2="NULL";0;ДЛСТР(G2)+1)+ЕСЛИ(H2="NULL";0;ДЛСТР(H2)+1)+1);ДЛСТР(B2)-(ЕСЛИ(D2="NULL";0;ДЛСТР(D2)+1)+ЕСЛИ(E2="NULL";0;ДЛСТР(E2)+1)+ЕСЛИ(F2="NULL";0;ДЛСТР(F2)+1)+ЕСЛИ(G2="NULL";0;ДЛСТР(G2)+1)+ЕСЛИ(H2="NULL";0;ДЛСТР(H2)+1)));"NULL");"NULL")

Главное, чтобы поля соответствовали нужным ячейкам, либо поменять названия ячеек в формулах.

="Модель " & B1 & " уникальная..."

Если извратиться конкретно с формулами без VBA, то так: ищет в первых 3-х ячейках, дальше изменяйте по аналогии.
=ПСТР(A1&B1&C1;ПОИСК("??.??.????";A1&B1&C1;1);10)

Почитайте про функцию ВПР(), должна справиться.

Можно конечно макросом, но если строчек будет 10000 или часто вносится изменения - нецелесообразно
Есть уже встроенные методы:

Вот вам неймется :) пока с работы ехал еще вопрос придумали!
Пробуйте это:

Sub Macros()
    Dim i, j, counter As Integer
    
    counter = 1
    i = 1
    While Sheets("Лист1").Cells(i, 1) <> ""
        j = 2
        While Sheets("Лист1").Cells(i, j) <> ""
            Sheets("Лист2").Cells(counter, 1) = Sheets("Лист1").Cells(i, 1) & Sheets("Лист1").Cells(i, j)
            counter = counter + 1
            j = j + 1
        Wend
        i = i + 1
    Wend
End Sub

UpD:

Sub Macros()
    Dim i, j, counter As Integer
    
    counter = 1
    i = 1
    While Sheets("11").Cells(i, 1) <> ""
        j = 2
        While Sheets("11").Cells(i, j) <> "Конец"
            If Sheets("11").Cells(i, j) = "" Then
                j = j + 1
            Else
                Sheets("22").Cells(counter, 1) = Sheets("11").Cells(i, 1)
                Sheets("22").Cells(counter, 2) = Sheets("11").Cells(i, j)
                counter = counter + 1
                j = j + 1
            End If
        Wend
        i = i + 1
    Wend
End Sub

Да нет, с синтаксисом порядок, у меня отработал без ошибок.
А на что ругается, может вместо "list2" написать "Лист2"?

Полезно будет использовать записью макроса

А если циклом пробегать каждую ячейку из Range["A4", "A" + firstCellDestination.Row] и не удалять те, которые начинаются со знака "=".

На панели "Разработчик" есть кнопка "Запись макроса":
- жмакаете на нее;
- делаете необходимые процедуры (перемещение\удаление слов);
- останавливаете запись;
- смотрите получившийся код;
- удаляете лишнее. добавляете необходимое.

Не совсем понятно как будут программно отбираться слова?

UpD (вот что получилось у меня):

Private Sub CommandButton1_Click()
    Dim key_word As String ' ключевое слово, по которому будем отбирать
    Dim i, count As Integer
        
    key_word = TextBox1.Text
    Sheets("Лист1").Select
    count = 0
    i = 1
    While (Cells(i, 1) <> "") ' проходим до первой пустой ячейки столбец А '
        If (InStr(1, LCase(Cells(i, 1)), LCase(key_word), vbBinaryCompare) > 0) Then ' если совпало '
            count = count + 1
            Cells(i, 1).Select
            Selection.Cut ' вырезаем из Лист1 '
            Sheets("Лист2").Select
            Cells(count, 1).Select
            ActiveSheet.Paste ' вставляем в Лист2 '
            Sheets("Лист1").Select
        End If
        i = i + 1
    Wend
    Label1.Caption = "find: " & count
    
    i = i - 1
    While (i > 0)
        If (Cells(i, 1) = "") Then
            Cells(i, 1).Select
            Selection.Delete Shift:=xlUp ' в Лист1 удаляем все пустые ячейки со сдвигом вверх '
        End If
        i = i - 1
    Wend
End Sub

А в чем смысл данного действа, распишите подробнее? Почему одним файлом нельзя обойтись, просто разграничив права доступа к нему, например?
Можно попробовать подтягивать нужные данные тем же скриптом на VBA как вариант.