Anri_amar, вариант .Если ввести не дату - строка не переносится
Код
Private Sub Worksheet_Change(ByVal Target As Range)
With Sheets("На участке")
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, [e:e]) Is Nothing And IsDate(Target.Value) Then
.Rows(Target.Row).Copy Sheets("Отгружены").Rows(WorksheetFunction.CountA(Sheets("Отгружены").[a:a]) + 1)
.Rows(Target.Row).Delete
End If
End With
End Sub
Sub csg()
Dim FoundCell As Range, txt As Variant, FAdr As String
txt = Range("B17").Value
Set FoundCell = Range("G:G").Find(txt, , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
Do
Range(Cells(FoundCell.Row, 7), Cells(FoundCell.Row, 19)).ClearContents
'Range(Cells(FoundCell.Row, 7), Cells(FoundCell.Row, 19)).Delete Shift:=xlUp 'если нужно удалить со сдвигом вверх
Set FoundCell = Range("G:G").FindNext
Loop While Not FoundCell Is Nothing
End If
End Sub
Sub мкр3()
With Worksheets("Лист2")
Range("J9:J" & Cells(Rows.Count, "J").End(xlUp).Row).Copy
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End Sub
Kate_G, Добрый день. Не понял откуда брать данные для столбца " Банк/Филиалы"? Куда считать "СПО"? Или это и есть " Банк/Филиалы"? Решение макросом без столбца " Банк/Филиалы" и "СПО". Запускать с листа "отчет_присутствие"
Код
Sub csg()
Dim tt As Integer
Dim i As Long, j As Long, n As Long
Dim sh As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set sh = Sheets("исходные_данные (2)")
For i = 3 To 7
For j = 3 To Cells(Rows.Count, 1).End(xlUp).Row
For n = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
If Cells(j, i) = "" Then
If Cells(j, 1) = sh.Cells(n, 3) And Cells(2, i) = sh.Cells(n, 8) Then tt = tt + 1
End If
Next
Cells(j, i) = tt
tt = 0
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic '
End Sub
Sub ПереносСтрок()
Dim r As Range, lr As Long
lr = Cells(Rows.Count, 15).End(xlUp).Row
For Each r In Range(Cells(3, 15), Cells(lr, 15))
If r = "Назначена встреча" Then
Rows(r.Row).Copy Sheets("Результат").Cells(Rows.Count, 1).End(xlUp).Offset(1)
Rows(r.Row).Delete
End If
Next
End Sub
neqkeet, универсальный макрос. Таблицы могут находится на любых листах, в любом месте. Результат также выводится на любой лист. Диапазон таблицы указывать без шапки (неизвестно сколько строк может занимать шапка). Макрос можно запускать с любого листа.
Код
Sub csg()
Dim myRange1 As Range, myRange2 As Range, myRange3 As Range
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Dim iCell As Range, mCell As Range
Dim i1&, i2&, c1&, c2&, j1&, j2&, n1&, n2&, k1&, k2&
On Error GoTo Inform
Set myRange1 = Application.InputBox("Укажите первый диапазон:", "Выбор", Type:=8)
Set Ws1 = myRange1.Worksheet
i1 = myRange1.Row: i2 = myRange1(myRange1.Count).Row
c1 = myRange1.Column: c2 = myRange1(myRange1.Count).Column
Set myRange2 = Application.InputBox("Укажите второй диапазон:", "Выбор", Type:=8)
Set Ws2 = myRange2.Worksheet
j1 = myRange2.Row: j2 = myRange2(myRange2.Count).Row
n1 = myRange2.Column: n2 = myRange2(myRange2.Count).Column
Set myRange3 = Application.InputBox("Укажите ячейку для вставки:", "Выбор", Type:=8)
Set Ws3 = myRange3.Worksheet
k1 = myRange3.Row: k2 = myRange3.Column
For Each iCell In Ws1.Range(Ws1.Cells(i1, c1), Ws1.Cells(i2, c1))
For Each mCell In Ws2.Range(Ws2.Cells(j1, n1), Ws2.Cells(j2, n1))
If iCell <> "" Then
Ws1.Range(Ws1.Cells(iCell.Row, c1), Ws1.Cells(iCell.Row, c2)).Copy Ws3.Cells(k1, k2)
Ws2.Range(Ws2.Cells(mCell.Row, n1), Ws2.Cells(mCell.Row, n2)).Copy Ws3.Cells(k1, k2).Offset(0, c2 - c1 + 1)
k1 = k1 + 1
End If
Next
Next
Ws3.Activate
Exit Sub
Inform:
MsgBox "Диалог закрыт или нажата кнопка " _
& Chr(34) & "Отмена" & Chr(34) & "!"
Exit Sub
End Sub
Sub csg()
Dim iCell As Range, mCell As Range
Application.ScreenUpdating = False
For Each iCell In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
For Each mCell In Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
If iCell <> "" Then
If iCell = mCell And iCell.Offset(0, 4) = mCell.Offset(0, -4) Then
Rows(mCell.Row).Delete
End If
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Sub csg()
Dim iCell As Range, mCell As Range, FreeRow As Long, lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 11).End(xlUp).Row
If lr < 3 Then lr = 3
Range("K3:P" & lr).ClearContents
FreeRow = 3
For Each iCell In Range(Cells(3, "A"), Cells(Rows.Count, "A").End(xlUp))
For Each mCell In Range(Cells(3, "E"), Cells(Rows.Count, "E").End(xlUp))
If iCell <> "" Then
Range(Cells(iCell.Row, 1), Cells(iCell.Row, 2)).Copy Cells(FreeRow, 11)
Range(Cells(mCell.Row, 5), Cells(mCell.Row, 8).Copy Cells(FreeRow, 13)
FreeRow = FreeRow + 1
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Макрос не привязан жестко к листу, просто выгрузка данных пойдет на тот лист, с которого вы его запустите. А не срабатывает макрос на листе " Единицы", потому что названия отделений на листе у вас " Отд 01", а на листе "Октябрь" просто "1". Я писал об этом выше. Названия отделений должны быть написаны как угодно, но везде однообразно. Почему не работает на 2003, пока не знаю. Проверить не на чем. Опишите в чем сбой, что не работает. Кстати, вчера я перезалил файл, в старом файле был отладочный файл , если еще не скачали
samass, в макросе "Процедуры" считается сумма чисел в ячейках по каждому отделению.Если нужно просто количество заполненных ячеек по отделениям ,то тогда так
Код
Sub ПроцедурыЯчейки()
Dim tt As Integer
Dim i As Long, j As Long, n As Long
Dim Rng As Range, x As Range
Static Txt As String
Set Rng = Range("A1:U1")
Txt = InputBox("Введите месяц", "Поиск в строке '1'", Txt)
If Txt = "" Then Exit Sub
Set x = Rng.Find(what:=Txt)
With Sheets(Txt)
For i = 2 To 12
For j = 2 To 25
If Cells(i, 1) = Sheets(Txt).Cells(j, 10) Then
For n = 11 To 41
If Sheets(Txt).Cells(j, n) <> 0 Then tt = tt + 1
Next
End If
Next
If tt <> 0 Then
Cells(i, x.Column) = tt
tt = 0
End If
Next
End With
End Sub
samass, Если, правильно понял задачу, то макрос для "Пациенты"(запускать с листа " Пациенты")
Код
Sub Пациенты()
Dim tt As Integer
Dim i As Long, j As Long
Dim Rng As Range, x As Range
Static Txt As String
Set Rng = Range("A1:U1")
Txt = InputBox("Введите месяц", "Поиск в строке '1'", Txt)
If Txt = "" Then Exit Sub
Set x = Rng.Find(what:=Txt)
For i = 2 To 12
For j = 2 To 25
If Cells(i, 1) = Sheets(Txt).Cells(j, 10) Then tt = tt + 1
Next
If tt <> 0 Then
Cells(i, x.Column) = tt
tt = 0
End If
Next
End Sub
Для "Процедуры" (запускать с листа " Процедуры")
Код
Sub Процедуры()
Dim tt As Single
Dim i As Long, j As Long
Dim Rng As Range, x As Range
Static Txt As String
Set Rng = Range("A1:U1")
Txt = InputBox("Введите месяц", "Поиск в строке '1'", Txt)
If Txt = "" Then Exit Sub
Set x = Rng.Find(what:=Txt)
With Sheets(Txt)
For i = 2 To 12
For j = 2 To 25
If Cells(i, 1) = Sheets(Txt).Cells(j, 10) Then tt = tt + Application.Sum(.Range(.Cells(j, 11), .Cells(j, 41)))
Next
If tt <> 0 Then
Cells(i, x.Column) = tt
tt = 0
End If
Next
End With
End Sub
Важно: отделения на всех листах должно быть написано однообразно. Перезалил файл
Sub csg()
Dim myName
Dim iCell As Range
Dim ws1 As Worksheet
Dim ws As Worksheet
Set ws1 = Sheet1
For Each iCell In Range(Cells(2, "E"), Cells(Rows.Count, "E").End(xlUp))
myName = iCell
On Error Resume Next
If Sheets(myName) Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = myName
Set ws = ActiveSheet
ws.Cells(1, 1) = myName
Range(ws1.Cells(1, 1), ws1.Cells(1, 5)).Copy ws.Cells(2, 1)
Range(ws1.Cells(iCell.Row, 1), ws1.Cells(iCell.Row, 5)).Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Else
Range(ws1.Cells(iCell.Row, 1), ws1.Cells(iCell.Row, 5)).Copy Sheets(myName).Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
Next
End Sub
Sub СкрытьСтроки()
Application.ScreenUpdating = False
Dim c As Range, LRow As Long, a As Variant, iCell As Range
LRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range(Cells(3, 122), Cells(LRow, 122))
If c = 0 Then
a = c.Offset(0, -119).Value
Set iCell = Range(Cells(2, 3), Cells(LRow, 3)).Find(a)
Rows(iCell.Row).Resize(4).EntireRow.Hidden = True
End If
Next
Application.ScreenUpdating = True
End Sub
Sub Скрыть_Строки()
Application.ScreenUpdating = False
Dim c As Range, LRow As Long
LRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range(Cells(3, 22), Cells(LRow, 22))
If c = 0 Then
c.EntireRow.Hidden = True
End If
Next
Application.ScreenUpdating = True
End Sub
Sub Скрыть_Столбцы()
Application.ScreenUpdating = False
Dim c As Range, lCol As Long
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For Each c In Range(Cells(1, 5), Cells(1, lCol))
If c = 0 Then
c.EntireColumn.Hidden = True
End If
Next
Application.ScreenUpdating = True
End Sub
Sub Макрос1()
Dim lr As Long, i As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For i = lr To 2 Step -1
If Cells(i, 2) = "" Then
Cells(i - 1, 1) = Cells(i - 1, 1) & Cells(i, 1)
Rows(i).Delete
End If
Next
End Sub