Добрый день! В теме nilem предложил вариант реализации журнала событий путем вызова окна сообщения нажатием правой клавиши мышкой в поле "Статус" листа "Таблица". В итоговом виде этот код выглядит следующим образом: [vba]
Код
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range("r7:r1000")) Is Nothing Then Exit Sub Cancel = True Dim s$, i As Integer With Sheets("История").Rows(Target.Row) For i = 6 To 56 Step 5 If (.Cells(i) <> "") And (.Cells(i + 1) = "") Then s = s & .Cells(i) & " " & .Cells(i - 2) & " направл. " & .Cells(i - 1) & vbCrLf ElseIf (.Cells(i) <> "") And (.Cells(i + 1) <> "") Then s = s & .Cells(i + 1) & " " & .Cells(i - 2) & " " & .Cells(i + 2) & " " & .Cells(i - 1) & vbCrLf ElseIf (.Cells(i) = "") And (.Cells(i + 1) <> "") Then s = s & .Cells(i + 1) & " " & .Cells(i - 2) & " " & .Cells(i + 2) & " " & .Cells(i - 1) & vbCrLf End If Next End With MsgBox s, 64 End Sub
[/vba] На следующем этапе встала задача создать 2 перекрестных файла, в которых общая информация совпадает, однако журнал событий разный. Данной проблеме была посвящена тема. Здесь меня уже выручил RAN Теперь остался последний этап - объединение журналов событий в третьем файле, файле Босса. Макрос для переброски данных я сделал аналогичному второму этапу, где мне помог RAN. Но встал вопрос. Как объединить историю событий из двух файлов в один... При нажатии правой кнопкой мыши на ячейке в поле "Статус" необходимо собрать историю по данной строке (записи) из двух файлов и выстроить ее в хронологическом порядке. С чего начать, подскажите, пожалуйста.
Добрый день! В теме nilem предложил вариант реализации журнала событий путем вызова окна сообщения нажатием правой клавиши мышкой в поле "Статус" листа "Таблица". В итоговом виде этот код выглядит следующим образом: [vba]
Код
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range("r7:r1000")) Is Nothing Then Exit Sub Cancel = True Dim s$, i As Integer With Sheets("История").Rows(Target.Row) For i = 6 To 56 Step 5 If (.Cells(i) <> "") And (.Cells(i + 1) = "") Then s = s & .Cells(i) & " " & .Cells(i - 2) & " направл. " & .Cells(i - 1) & vbCrLf ElseIf (.Cells(i) <> "") And (.Cells(i + 1) <> "") Then s = s & .Cells(i + 1) & " " & .Cells(i - 2) & " " & .Cells(i + 2) & " " & .Cells(i - 1) & vbCrLf ElseIf (.Cells(i) = "") And (.Cells(i + 1) <> "") Then s = s & .Cells(i + 1) & " " & .Cells(i - 2) & " " & .Cells(i + 2) & " " & .Cells(i - 1) & vbCrLf End If Next End With MsgBox s, 64 End Sub
[/vba] На следующем этапе встала задача создать 2 перекрестных файла, в которых общая информация совпадает, однако журнал событий разный. Данной проблеме была посвящена тема. Здесь меня уже выручил RAN Теперь остался последний этап - объединение журналов событий в третьем файле, файле Босса. Макрос для переброски данных я сделал аналогичному второму этапу, где мне помог RAN. Но встал вопрос. Как объединить историю событий из двух файлов в один... При нажатии правой кнопкой мыши на ячейке в поле "Статус" необходимо собрать историю по данной строке (записи) из двух файлов и выстроить ее в хронологическом порядке. С чего начать, подскажите, пожалуйста.Мурад
Не могу понять, как прописать присвоение диапазона массиву. Работу по упорядочиванию массивов записей по дате передачи решил осуществлять пузырьковым методом: [vba]
Код
for i=1 to n-1 do for j=i+1 to n do if a[j]>a[i] then temp=a[j] a[j]=a[i] a[i]=temp endif next next end
[/vba] На этом коде решил построить свой: [vba]
Код
Dim s$, i, j, k As Integer DateRange(1 To 22) As Range '22 этапа, каждый из которых состоит из 1.Документ, 2.Проверяющий, 3.Дата передачи, 4.Дата возврата, 5.Решение. Дата передачи 1го этапа начинается с 6го столбца For k=1 to 22 ' Цикл по этапам For i=6 to 106 step 5 For j=i+5 to 111 step 5 With Sheets("История согласования").Rows(Target.Row) If .Cells(j) > .Cells(i) Then DateRange(k) = Range.Cells(i-2, i+2) 'Вот здесь я совсем запутался. Скажите, подход в корне неверный? End If End With Next Next Next
[/vba]
Не могу понять, как прописать присвоение диапазона массиву. Работу по упорядочиванию массивов записей по дате передачи решил осуществлять пузырьковым методом: [vba]
Код
for i=1 to n-1 do for j=i+1 to n do if a[j]>a[i] then temp=a[j] a[j]=a[i] a[i]=temp endif next next end
[/vba] На этом коде решил построить свой: [vba]
Код
Dim s$, i, j, k As Integer DateRange(1 To 22) As Range '22 этапа, каждый из которых состоит из 1.Документ, 2.Проверяющий, 3.Дата передачи, 4.Дата возврата, 5.Решение. Дата передачи 1го этапа начинается с 6го столбца For k=1 to 22 ' Цикл по этапам For i=6 to 106 step 5 For j=i+5 to 111 step 5 With Sheets("История согласования").Rows(Target.Row) If .Cells(j) > .Cells(i) Then DateRange(k) = Range.Cells(i-2, i+2) 'Вот здесь я совсем запутался. Скажите, подход в корне неверный? End If End With Next Next Next
Pelena, Там простой случай описывается.. У меня 22 диапазона по 5 ячеек, идущих друг за другом. В середине каждого из диапазона находится проверяемый элемент..
Pelena, Там простой случай описывается.. У меня 22 диапазона по 5 ячеек, идущих друг за другом. В середине каждого из диапазона находится проверяемый элемент..Мурад
Выкладываю последний вариант файла. На листе "Таблица" при нажатии правой кнопкой мыши выскакивает окно сообщения с журналом событий. Как вы заметите, события в этом журнале не выстраиваются в хронологическом порядке. Они идут в том порядке, в котором они занесены на листе "История согласования". Конечная цель состоит в том, чтобы выстроить в окне сообщения журнал событий в хронологическом порядке.
Выкладываю последний вариант файла. На листе "Таблица" при нажатии правой кнопкой мыши выскакивает окно сообщения с журналом событий. Как вы заметите, события в этом журнале не выстраиваются в хронологическом порядке. Они идут в том порядке, в котором они занесены на листе "История согласования". Конечная цель состоит в том, чтобы выстроить в окне сообщения журнал событий в хронологическом порядке.Мурад
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range("r7:r1000")) Is Nothing Then Exit Sub Cancel = True Dim s$, i& With Sheets("История согласования").Rows(Target.Row) For i = 6 To 111 Step 5 If (.Cells(i) <> "") And (.Cells(i + 1) = "") Then s = s & .Cells(i) & " " & .Cells(i - 2) & " направл. " & .Cells(i - 1) & vbCrLf ElseIf (.Cells(i) <> "") And (.Cells(i + 1) <> "") Or (.Cells(i) = "") And (.Cells(i + 1) <> "") Then s = s & .Cells(i + 1) & " " & .Cells(i - 2) & " " & .Cells(i + 2) & " " & .Cells(i - 1) & vbCrLf End If Next End With If s = vbNullString Then Exit Sub Dim sp, arr() sp = Split(Mid(s, 1, Len(s) - 1), vbCrLf) If UBound(sp) = 0 Then MsgBox s, 64: Exit Sub ReDim arr(1 To UBound(sp) + 1, 1 To 2) For i = 0 To UBound(sp) arr(i + 1, 1) = CDate(Split(sp(i))(0)) arr(i + 1, 2) = sp(i) Next i arr = ShellSort22(arr, 1) MsgBox Join(Application.Transpose(Application.Index(arr, 0, 2)), Chr(10)), 64 End Sub
[/vba]
и еще добавим функцию
[vba]
Код
Function ShellSort22(x, k As Long) '*** сортируем 2-мерный массив x по столбцу k Dim Limit As Long, Switch As Long, i&, j&, u& Dim ubx&, t ubx = UBound(x, 2): j = (UBound(x) - LBound(x) + 1) \ 2 Do While j > 0 Limit = UBound(x) - j Do Switch = LBound(x) - 1 For i = LBound(x) To Limit If x(i, k) > x(i + j, k) Then 'по возрастанию ' If x(i, k) < x(i + j, k) Then 'по убыванию For u = 1 To ubx t = x(i, u) x(i, u) = x(i + j, u) x(i + j, u) = t Next Switch = i End If Next Limit = Switch - j Loop While Switch >= LBound(x) j = j \ 2 Loop: ShellSort22 = x End Function
[/vba]
можно дописать код
[vba]
Код
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range("r7:r1000")) Is Nothing Then Exit Sub Cancel = True Dim s$, i& With Sheets("История согласования").Rows(Target.Row) For i = 6 To 111 Step 5 If (.Cells(i) <> "") And (.Cells(i + 1) = "") Then s = s & .Cells(i) & " " & .Cells(i - 2) & " направл. " & .Cells(i - 1) & vbCrLf ElseIf (.Cells(i) <> "") And (.Cells(i + 1) <> "") Or (.Cells(i) = "") And (.Cells(i + 1) <> "") Then s = s & .Cells(i + 1) & " " & .Cells(i - 2) & " " & .Cells(i + 2) & " " & .Cells(i - 1) & vbCrLf End If Next End With If s = vbNullString Then Exit Sub Dim sp, arr() sp = Split(Mid(s, 1, Len(s) - 1), vbCrLf) If UBound(sp) = 0 Then MsgBox s, 64: Exit Sub ReDim arr(1 To UBound(sp) + 1, 1 To 2) For i = 0 To UBound(sp) arr(i + 1, 1) = CDate(Split(sp(i))(0)) arr(i + 1, 2) = sp(i) Next i arr = ShellSort22(arr, 1) MsgBox Join(Application.Transpose(Application.Index(arr, 0, 2)), Chr(10)), 64 End Sub
[/vba]
и еще добавим функцию
[vba]
Код
Function ShellSort22(x, k As Long) '*** сортируем 2-мерный массив x по столбцу k Dim Limit As Long, Switch As Long, i&, j&, u& Dim ubx&, t ubx = UBound(x, 2): j = (UBound(x) - LBound(x) + 1) \ 2 Do While j > 0 Limit = UBound(x) - j Do Switch = LBound(x) - 1 For i = LBound(x) To Limit If x(i, k) > x(i + j, k) Then 'по возрастанию ' If x(i, k) < x(i + j, k) Then 'по убыванию For u = 1 To ubx t = x(i, u) x(i, u) = x(i + j, u) x(i + j, u) = t Next Switch = i End If Next Limit = Switch - j Loop While Switch >= LBound(x) j = j \ 2 Loop: ShellSort22 = x End Function