nipolka,для раздумий - на плюс минус двойным кликом, а еще у вас общая тема такию тут в разделе работа решают, а в этой ветке конкретный вопрос
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Dim Product As Range, dataa As Range 'объявление переменных
If Not Intersect(Target, Range("i19,k19,m19,o19,q19,s19,u19,w19")) Is Nothing Then ' отслеживание двоеного нажатия на указанные ячейки
Target.Offset(0, -1) = Target.Offset(0, -1) + 1 'если одна из указанных выше ячеек тогда прибавляем 1 к значению
Set Product = Columns(27).Find(Target.Offset(-1, -1)) 'ищем продукт которому добавляли
Set dataa = Rows(15).Find(Date) 'ищем сегодняшнюю дату
Cells(Product.Row, dataa.Column + 1) = Cells(Product.Row, dataa.Column + 1) + 1 'добавляем единичку под сегодняшней датой в столбец приход
Cancel = True
End If
If Not Intersect(Target, Range("i20,k20,m20,o20,q20,s20,u20,w20")) Is Nothing Then ' отслеживание двоеного нажатия на указанные ячейки
Target.Offset(-1, -1) = Target.Offset(-1, -1) - 1'если одна из указанных выше ячеек тогда прибавляем 1 к значению
Set Product = Columns(27).Find(Target.Offset(-2, -1)) 'ищем продукт у которого отнимали
Set dataa = Rows(15).Find(Date) 'ищем сегодняшнюю дату
Cells(Product.Row, dataa.Column) = Cells(Product.Row, dataa.Column) - 1 'отнимаем единичку под сегодняшней датой в столбец расход
Cancel = True
End If
End Sub
Sub mrshkei()
Dim i As Long, j As Long, arrIN, arrOUT, k As Long, x As Long
k = 1
arrIN = Range("A1:G4")
x = (UBound(arrIN) - 1) * (UBound(arrIN, 2) - LBound(arrIN, 2))
ReDim arrOUT(1 To x, 1 To 3)
For j = LBound(arrIN) + 1 To UBound(arrIN)
For i = LBound(arrIN) + 1 To UBound(arrIN, 2) - LBound(arrIN, 2) + 1
arrOUT(k, 1) = arrIN(j, 1)
arrOUT(k, 2) = arrIN(1, i)
arrOUT(k, 3) = arrIN(j, i)
k = k + 1
Next i
Next j
Range("A7").Resize(UBound(arrOUT), 3) = arrOUT
End Sub
memo написал: Кстати, интересно было бы увидеть формульный вариант.
согласен) только кажется будет тормозить) и еще вариант (3 млн. ячеек 6 сек. вроде подойдет Вам) - диапазон свой задайте только
Код
Sub mrshkei()
a = Timer
Dim arr, i As Long, j As Long, col As New Collection
arr = Range("D2:AG99999")
For i = LBound(arr) To UBound(arr)
For j = LBound(arr) To UBound(arr, 2) - LBound(arr, 2) + 1
On Error Resume Next
col.Add arr(i, j), CStr(arr(i, j))
Next j
Next i
ReDim arr(1 To col.Count, 1 To 1)
For i = 1 To col.Count
arr(i, 1) = col(i)
Next i
Range("AI2").Resize(UBound(arr), 1) = arr
Debug.Print Timer - a
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, [AW4]) Is Nothing Then
Dim r As Range, c As Range
Set r = Columns(1).Find([AW2])
Set c = Rows(1).Find([AW3])
Cells(r.Row, c.Column) = [AW4]
End If
End Sub
New, а фиг его знает ) что-то в процессе думал удалил, а кусок остался))
Код
Sub mrshkei()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
arr = Split(Cells(i, 1), ";")
For n = LBound(arr) To UBound(arr)
t = t & " " & n + 1 & ". " & arr(n)
Next n
Cells(i, 2) = t & ".": t = Empty
Next i
End Sub
Sub mrshkei()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
arr = Split(Cells(i, 1), ";")
For n = LBound(arr) To UBound(arr)
x = UBound(arr) + 1
t = t & " " & n + 1 & ". " & arr(n)
Next n
Cells(i, 2) = t & "."
t = Empty
Next i
End Sub
Sub mrshkei()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
arr = Split(Cells(i, 1), ";")
For n = LBound(arr) To UBound(arr)
x = UBound(arr) + 1
t = t & " " & n + 1 & ". " & arr(n)
Next n
Cells(i, 2) = t
t = Empty
Next i
End Sub
Sub mrshkei()
Dim arr
arr = Range("A2:A15")
For i = LBound(arr) To UBound(arr)
x = Application.InputBox(arr(i, 1), Type:=2)
lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(lr, 2) = x
Next i
End Sub
Дмитрий Рыбин, в PQ не знаю смогут ли помочь, а вариант обновлять запрос может через макрос и перед обновлением создавать лист дубликат, потом обновлять данные и после проходить проходить по каждому значению листа дубликата и искать "Обозначение" - если оно найдено в новом запросе перемещать в него старый "Статус ОМТС"... обозначения же не повторяются как я понял
Виктор Иванов, я не предлагал вам формулу...если хотите формулой то так кка у вас все данные одинаковой стркутуры, то для первой таблицы в ячейку M4
Код
=I5
в ячейку М5 и протянуть до М11
Код
=M4
затем выделяете диапазон М4:М11 и тяните за правый нижний уголок вниз.
ну и код :
Код
Sub mrshkei()
Dim i As Long, lr As Long
lr = Cells(Rows.Count, 9).End(xlUp).Row
For i = 5 To lr Step 8
Range(Cells(i - 1, 15), Cells(i + 6, 15)) = Cells(i, 9)
Next
End Sub
Sub mrshkei()
Dim i As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To lr Step 8
Cells(i, 1).Copy Destination:=Range(Cells(i + 1, 1), Cells(i + 7, 1))
Next
End Sub
aniramulis, как вариант так - присвоить на листе заказчик каждому инженеру цвет (заливкой).
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target = Empty Then Exit Sub
If Not Intersect(Target, Range("E6:AI11")) Is Nothing Then
Dim cell As Range, sh As Worksheet
Set sh = Worksheets("Заказчик")
Set cell = sh.Columns(1).Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
Cells(Target.Row, Target.Column).Interior.ColorIndex = cell.Offset(0, 4).Interior.ColorIndex
If (Cells(Target.Row, Target.Column).Comment Is Nothing) Then
Cells(Target.Row, Target.Column).AddComment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
Else
Cells(Target.Row, Target.Column).Comment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
End If
Else
MsgBox "УКАЗАННЫЙ ПРОЕКТ НЕ НАЙДЕН"
End If
End If
End Sub
aniramulis, не очень понял...ну может так (вносит номера проектов на листе исполнит.)
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target = Empty Then Exit Sub
If Not Intersect(Target, Range("E6:AI11")) Is Nothing Then
Dim cell As Range, sh As Worksheet
Set sh = Worksheets("Заказчик")
Set cell = sh.Columns(1).Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
Cells(Target.Row, Target.Column).Interior.ColorIndex = cell.Row - 1
If (Cells(Target.Row, Target.Column).Comment Is Nothing) Then
Cells(Target.Row, Target.Column).AddComment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
Else
Cells(Target.Row, Target.Column).Comment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
End If
Else
MsgBox "УКАЗАННЫЙ ПРОЕКТ НЕ НАЙДЕН"
End If
End If
End Sub
aniramulis написал: Есть менеджер, который ищет клиентов и заключает контрактыЕсть инженер, который все это переводит в смету и далее передает исполнителямОни присваивают номер для полученного заказа - "Проекта"
ни менеджера, ни инженера ровным счетом ничего у нас нет (это только у вас)
пы.сы. нужен файл-пример с исходными данным и показанным отдельно желаемым результатом *ручками сделать а еще забыл - название темы общее не отражает сути(конкретики) - модераторы скорее всего ее удалят или как минимум скрою помощь, (предложите в тексте новое а модераторы заменят)