Пытался сам не вышло, сделал нелепое подобие задачи (не хотел извращаться над рабочим документом), но её решение не дало нужного результата, поэтому максимально облегчил рабочую книгу. В ней порядка 30 листов, но это не так важно. Суть помощи, если она конечно возможна, сделать чтоб данные с листа "Сбор" перекочевали на лист "Выполнено", при совпадении Номера детали и операции кол-во суммировалось. Т.е мне нужны только 3,4 и 6 столбцы. Ручной труд тяжёл, готов прислушаться к любому решению данной загигулины.
Пытался сам не вышло, сделал нелепое подобие задачи (не хотел извращаться над рабочим документом), но её решение не дало нужного результата, поэтому максимально облегчил рабочую книгу. В ней порядка 30 листов, но это не так важно. Суть помощи, если она конечно возможна, сделать чтоб данные с листа "Сбор" перекочевали на лист "Выполнено", при совпадении Номера детали и операции кол-во суммировалось. Т.е мне нужны только 3,4 и 6 столбцы. Ручной труд тяжёл, готов прислушаться к любому решению данной загигулины. ZamoK
Sub Gav() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("C2:F" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 1) & "||" & dx(n, 2) If dx(n, 4) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 4) Else dict.Item(Key) = CDbl(dx(n, 4)) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 3)
Keys = dict.Keys For n = 0 To dict.Count - 1 R_Out(n + 1, 1) = Split(Keys(n), "||")(0) R_Out(n + 1, 2) = Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 3) = R_Out End Sub
[/vba]
Беру плохой пример у котов [vba]
Код
Sub Gav() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("C2:F" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 1) & "||" & dx(n, 2) If dx(n, 4) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 4) Else dict.Item(Key) = CDbl(dx(n, 4)) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 3)
Keys = dict.Keys For n = 0 To dict.Count - 1 R_Out(n + 1, 1) = Split(Keys(n), "||")(0) R_Out(n + 1, 2) = Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 3) = R_Out End Sub
gling, Спасибо за оперативный отклик, вариант очень хороший, но данные обновляются несколько раз в течении рабочей смены, и копирование данных не совсем удобная штука. С помощью массива я уже пробовал. Вопрос размещён в теме VBA и хотелось бы решить с помощью макроса и заветной кнопочки. Да и книга максимально облегчена, не хотелось бы протягивать каждый раз формулу , но все ровно большое спасибо !
gling, Спасибо за оперативный отклик, вариант очень хороший, но данные обновляются несколько раз в течении рабочей смены, и копирование данных не совсем удобная штука. С помощью массива я уже пробовал. Вопрос размещён в теме VBA и хотелось бы решить с помощью макроса и заветной кнопочки. Да и книга максимально облегчена, не хотелось бы протягивать каждый раз формулу , но все ровно большое спасибо !ZamoK
Не посчитайте за дерзость , но можно ли добавить чтоб в ячейке справа через запятую были бы фамилии тех кто делал т.е. фамилии с второго столбца, если нет то и так уже прогресс огромное спасибо
Не посчитайте за дерзость , но можно ли добавить чтоб в ячейке справа через запятую были бы фамилии тех кто делал т.е. фамилии с второго столбца, если нет то и так уже прогресс огромное спасибоZamoK
Sub Gav_Modern() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Фио = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("B2:F" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 1) & "||" & dx(n, 3) If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 5) Else dict.Item(Key) = CDbl(dx(n, 5)) Фио.Item(Key) = dx(n, 1) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 4)
Keys = dict.Keys For n = 0 To dict.Count - 1 R_Out(n + 1, 1) = "'" & Split(Keys(n), "||")(0) R_Out(n + 1, 2) = "'" & Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) R_Out(n + 1, 4) = Фио.Item(Keys(n)) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 4) = R_Out End Sub
[/vba]
Можно [vba]
Код
Sub Gav_Modern() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Фио = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("B2:F" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 1) & "||" & dx(n, 3) If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 5) Else dict.Item(Key) = CDbl(dx(n, 5)) Фио.Item(Key) = dx(n, 1) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 4)
Keys = dict.Keys For n = 0 To dict.Count - 1 R_Out(n + 1, 1) = "'" & Split(Keys(n), "||")(0) R_Out(n + 1, 2) = "'" & Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) R_Out(n + 1, 4) = Фио.Item(Keys(n)) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 4) = R_Out End Sub
Sub Gav_Modern() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Фио = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("B2:F" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 2) & "||" & dx(n, 3) If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 5) Else dict.Item(Key) = CDbl(dx(n, 5)) Фио.Item(Key) = dx(n, 1) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 4)
Keys = dict.Keys For n = 0 To dict.Count - 1 R_Out(n + 1, 1) = "'" & Split(Keys(n), "||")(0) R_Out(n + 1, 2) = "'" & Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) R_Out(n + 1, 4) = Фио.Item(Keys(n)) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 4) = R_Out End Sub
[/vba]
Значит тк и будет
[vba]
Код
Sub Gav_Modern() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Фио = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("B2:F" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 2) & "||" & dx(n, 3) If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 5) Else dict.Item(Key) = CDbl(dx(n, 5)) Фио.Item(Key) = dx(n, 1) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 4)
Keys = dict.Keys For n = 0 To dict.Count - 1 R_Out(n + 1, 1) = "'" & Split(Keys(n), "||")(0) R_Out(n + 1, 2) = "'" & Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) R_Out(n + 1, 4) = Фио.Item(Keys(n)) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 4) = R_Out End Sub
If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 5) 'добавите эти строки и будет счастье '.............................. if instr(1,Фио.Item(Key) , dx(n, 1),vbTextCompare)=0 then Фио.Item(Key) =Фио.Item(Key) & "," & dx(n, 1) end if ',,,,,,,,,,,,,,,,,,,,,,,,,,,, Else dict.Item(Key) = CDbl(dx(n, 5)) Фио.Item(Key) = dx(n, 1) End If End If
[/vba]
[vba]
Код
If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + dx(n, 5) 'добавите эти строки и будет счастье '.............................. if instr(1,Фио.Item(Key) , dx(n, 1),vbTextCompare)=0 then Фио.Item(Key) =Фио.Item(Key) & "," & dx(n, 1) end if ',,,,,,,,,,,,,,,,,,,,,,,,,,,, Else dict.Item(Key) = CDbl(dx(n, 5)) Фио.Item(Key) = dx(n, 1) End If End If
Я тут попробовал в действии сие волшебство и заметил одну неурядицу. Но это не код, а моя ошибка (...упс, не поная информация, а работа для меня новая): в листе Сбор есть столбец G в нем процент выполнения, и число которое слева от процента должно предварительно умножиться на него и уже затем суммироваться и попадать в "Выпуск". Можно ли добавить умножение?
Я тут попробовал в действии сие волшебство и заметил одну неурядицу. Но это не код, а моя ошибка (...упс, не поная информация, а работа для меня новая): в листе Сбор есть столбец G в нем процент выполнения, и число которое слева от процента должно предварительно умножиться на него и уже затем суммироваться и попадать в "Выпуск". Можно ли добавить умножение?ZamoK
+ сортировка,на Шустов тянет Правил в блокноте,не ругать сильно.
[vba]
Код
Sub Gav_Modern() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Фио = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("B2:G" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 2) & "||" & dx(n, 3) If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + CDbl(dx(n, 5))* CDbl(dx(n, 6)) if instr(1,Фио.Item(Key) , dx(n, 1),vbTextCompare)=0 then Фио.Item(Key) =Фио.Item(Key) & "," & dx(n, 1) end if Else dict.Item(Key) = CDbl(dx(n, 5))* CDbl(dx(n, 6)) Фио.Item(Key) = dx(n, 1) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 4)
Keys = dict.Keys БубликSort Keys For n = 0 To ubound(Keys) R_Out(n + 1, 1) = "'" & Split(Keys(n), "||")(0) R_Out(n + 1, 2) = "'" & Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) R_Out(n + 1, 4) = Фио.Item(Keys(n)) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 4) = R_Out End Sub
Sub БубликSort(ByRef List) Dim First As Integer, Last As long Dim i As As long, j As As long Dim Temp As string First = LBound(List) Last = UBound(List) For i = First To Last - 1 For j = i + 1 To Last If List(i) > List(j) Then Temp = List(j) List(j) = List(i) List(i, 1) = Temp End If Next j Next i End Sub
[/vba]
+ сортировка,на Шустов тянет Правил в блокноте,не ругать сильно.
[vba]
Код
Sub Gav_Modern() Dim Sh As Worksheet, Key As String, R_Out Set dict = CreateObject("scripting.dictionary") Set Фио = CreateObject("scripting.dictionary") Set Sh = ThisWorkbook.Worksheets("Сбор") LastRow = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row dx = Sh.Range("B2:G" & LastRow) For n = 1 To UBound(dx) Key = dx(n, 2) & "||" & dx(n, 3) If dx(n, 5) <> "" Then If dict.Exists(Key) Then dict.Item(Key) = CDbl(dict.Item(Key)) + CDbl(dx(n, 5))* CDbl(dx(n, 6)) if instr(1,Фио.Item(Key) , dx(n, 1),vbTextCompare)=0 then Фио.Item(Key) =Фио.Item(Key) & "," & dx(n, 1) end if Else dict.Item(Key) = CDbl(dx(n, 5))* CDbl(dx(n, 6)) Фио.Item(Key) = dx(n, 1) End If End If Next ReDim R_Out(1 To dict.Count, 1 To 4)
Keys = dict.Keys БубликSort Keys For n = 0 To ubound(Keys) R_Out(n + 1, 1) = "'" & Split(Keys(n), "||")(0) R_Out(n + 1, 2) = "'" & Split(Keys(n), "||")(1) R_Out(n + 1, 3) = CDbl(dict.Item(Keys(n))) R_Out(n + 1, 4) = Фио.Item(Keys(n)) Next ThisWorkbook.Worksheets("Выполнено").Range("A2").Resize(dict.Count, 4) = R_Out End Sub
Sub БубликSort(ByRef List) Dim First As Integer, Last As long Dim i As As long, j As As long Dim Temp As string First = LBound(List) Last = UBound(List) For i = First To Last - 1 For j = i + 1 To Last If List(i) > List(j) Then Temp = List(j) List(j) = List(i) List(i, 1) = Temp End If Next j Next i End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
все стало на свои места.
