Здравствуйте уважаемые форумчане. В приложенный файл содержит лист "Исходный" и макрос Rabota. В результате работы макроса заполняется лист РКОФ (наименование должностей их количество по разным штатам). Столбцы 22 и 23 Исходного содержат информацию об убытии(прибытии) сотрудников, если убытие(прибытие) содержит "вч", то в РКОФ заполняются столбцы I и J, однако если содержится например "птб1", то это позиция существующей должности (3 столбец Исходного). Задача состоит в том, чтобы данные перемещения подсчитывались в результате работы макроса и заполнялись столбцы K,L,M,N листа РКОФ, причем столбцы K,M содержат количество, а L и N номера строк с реквизитами должностей (указанно в листе Образец файла примера), при чем если должностей несколько, то позиции перечисляются через запятую. Заранее спасибо.
Здравствуйте уважаемые форумчане. В приложенный файл содержит лист "Исходный" и макрос Rabota. В результате работы макроса заполняется лист РКОФ (наименование должностей их количество по разным штатам). Столбцы 22 и 23 Исходного содержат информацию об убытии(прибытии) сотрудников, если убытие(прибытие) содержит "вч", то в РКОФ заполняются столбцы I и J, однако если содержится например "птб1", то это позиция существующей должности (3 столбец Исходного). Задача состоит в том, чтобы данные перемещения подсчитывались в результате работы макроса и заполнялись столбцы K,L,M,N листа РКОФ, причем столбцы K,M содержат количество, а L и N номера строк с реквизитами должностей (указанно в листе Образец файла примера), при чем если должностей несколько, то позиции перечисляются через запятую. Заранее спасибо.Sashagor1982
Sub Rabota() Dim a(), b() Dim i&, n& Dim sd As Object, dicLeave As Object '-------------------- Set sd = CreateObject("Scripting.Dictionary") Set dicLeave = CreateObject("Scripting.Dictionary") Set dicArrive = CreateObject("Scripting.Dictionary") a = ThisWorkbook.Worksheets("Исходный").UsedRange.Value For i = 3 To UBound(a) If a(i, 8) = "оф." Or a(i, 9) = "оф." Then key_ = a(i, 4) & a(i, 5) & a(i, 6) If sd.Exists(key_) Then b = sd(key_) Else b = Array(a(i, 7), a(i, 4), a(i, 6), "'" & a(i, 5), Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, sd.Count + 1) If Len(a(i, 8)) Then b(4) = b(4) + 1 If Len(a(i, 9)) Then b(5) = b(5) + 1 If Len(a(i, 22)) Then If Left$(a(i, 22), 2) = "вч" Then b(6) = b(6) + 1 Else b(8) = b(8) + 1: dicLeave(a(i, 3)) = b(13) If Len(a(i, 23)) Then If Left$(a(i, 23), 2) = "вч" Then b(7) = b(7) + 1 Else b(12) = a(i, 23): b(10) = b(10) + 1 sd(key_) = b End If Next
a = sd.items For i = 0 To UBound(a) If Len(a(i)(12)) Then If dicLeave.Exists(a(i)(12)) Then n = dicLeave(a(i)(12)): a(i)(11) = n: n = n - 1: a(n)(9) = IIf(Len(a(n)(9)), a(n)(9) & ";", "") & i + 1 Next
With ThisWorkbook.Worksheets("РКОФ") With .Cells(7, 1) .Value = 1 With .Resize(sd.Count) .DataSeries .Offset(, 2).Resize(, 12).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(a)) End With End With .Activate End With Beep End Sub
[/vba]
[p.s.]и судя по всему, в ячейке W357 должно быть "птб15", а не "птб13"[/p.s.]
Добрый день! Проверьте [vba]
Код
Sub Rabota() Dim a(), b() Dim i&, n& Dim sd As Object, dicLeave As Object '-------------------- Set sd = CreateObject("Scripting.Dictionary") Set dicLeave = CreateObject("Scripting.Dictionary") Set dicArrive = CreateObject("Scripting.Dictionary") a = ThisWorkbook.Worksheets("Исходный").UsedRange.Value For i = 3 To UBound(a) If a(i, 8) = "оф." Or a(i, 9) = "оф." Then key_ = a(i, 4) & a(i, 5) & a(i, 6) If sd.Exists(key_) Then b = sd(key_) Else b = Array(a(i, 7), a(i, 4), a(i, 6), "'" & a(i, 5), Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, sd.Count + 1) If Len(a(i, 8)) Then b(4) = b(4) + 1 If Len(a(i, 9)) Then b(5) = b(5) + 1 If Len(a(i, 22)) Then If Left$(a(i, 22), 2) = "вч" Then b(6) = b(6) + 1 Else b(8) = b(8) + 1: dicLeave(a(i, 3)) = b(13) If Len(a(i, 23)) Then If Left$(a(i, 23), 2) = "вч" Then b(7) = b(7) + 1 Else b(12) = a(i, 23): b(10) = b(10) + 1 sd(key_) = b End If Next
a = sd.items For i = 0 To UBound(a) If Len(a(i)(12)) Then If dicLeave.Exists(a(i)(12)) Then n = dicLeave(a(i)(12)): a(i)(11) = n: n = n - 1: a(n)(9) = IIf(Len(a(n)(9)), a(n)(9) & ";", "") & i + 1 Next
With ThisWorkbook.Worksheets("РКОФ") With .Cells(7, 1) .Value = 1 With .Resize(sd.Count) .DataSeries .Offset(, 2).Resize(, 12).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(a)) End With End With .Activate End With Beep End Sub
[/vba]
[p.s.]и судя по всему, в ячейке W357 должно быть "птб15", а не "птб13"[/p.s.]KSV
Лист "Исходный": строка 388 - убывает на буар8 строка 391 - прибывает из буар8 строка 397 - тот самый буар8, но он понятия не имеет, что он должен куда-то убыть и откуда-то прибыть
Вопрос: "Это нормально или ошибка в данных?"
Пробуйте. Module2.Rabota
Лист "Исходный": строка 388 - убывает на буар8 строка 391 - прибывает из буар8 строка 397 - тот самый буар8, но он понятия не имеет, что он должен куда-то убыть и откуда-то прибыть