Иван Романов, а что делают эти формулы? может есть смысл написать одну красивую? Определить разницу в годах между двумя датам и присвоить значение согласно диапазону вхождения
Прибавление часов в реальном времени, Необходимо в уже существующим моточасам машины (26210) прибавлять в режиме онлайн каждый час, в зависимости от реального времени
Правила написал: 2.2. Опишите максимально подробно вашу задачу и желаемый результат. Желательно уточнить вашу версию Excel. 2.3. Приложите файл(ы) с примером (общим весом не более 300Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
2.2. Опишите максимально подробно вашу задачу и желаемый результат. Желательно уточнить вашу версию Excel. 2.3. Приложите файл(ы) с примером (общим весом не более 300Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
Sub mrshkei()
Dim arr, arr2, arr3, i As Long, lr As Long, sh As Worksheet, col As New Collection
For Each sh In Worksheets
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
arr = sh.Range("a5:f" & lr)
For i = LBound(arr) To UBound(arr)
If arr(i, 1) <> Empty Then
On Error Resume Next
col.Add (arr(i, 1) & "::" & arr(i, 2) & "::" & arr(i, 3) & "::" & arr(i, 5) & "::" & arr(i, 6)), _
CStr(arr(i, 1) & "::" & arr(i, 2) & "::" & arr(i, 3) & "::" & arr(i, 5) & "::" & arr(i, 6))
End If
Next i
ReDim arr2(1 To col.Count, 1 To 6)
For i = 1 To col.Count
arr3 = Split(col(i), "::")
arr2(i, 1) = arr3(0)
arr2(i, 2) = arr3(1)
arr2(i, 3) = arr3(2)
arr2(i, 5) = arr3(3)
arr2(i, 6) = arr3(4)
arr2(i, 4) = Application.WorksheetFunction.SumIfs(sh.Columns(4), sh.Columns(1), arr2(i, 1), sh.Columns(2), arr2(i, 2), sh.Columns(3), arr2(i, 3), sh.Columns(5), arr2(i, 5), sh.Columns(6), arr2(i, 6))
Next i
sh.Range("A5:F" & lr + 2).ClearContents
sh.Range("A5").Resize(UBound(arr2), 6) = arr2
Set col = Nothing
Next sh
End Sub
Sub mrshkei()
Dim arr, arr2, i As Long, n As Long, lr As Long, col As New Collection
lr = Cells(Rows.Count, 6).End(xlUp).Row
arr = Range("F2:I" & lr)
For i = LBound(arr) To UBound(arr)
If arr(i, 4) <> Empty Then
On Error Resume Next
col.Add arr(i, 4), CStr(arr(i, 4))
End If
Next i
ReDim arr2(0 To UBound(arr) + 1, 1 To 3)
arr2(0, 1) = "Телефон": arr2(0, 2) = "МинДАТА": arr2(0, 3) = "МаксДАТА"
For i = 1 To col.Count
MMax = Application.WorksheetFunction.Min(Columns(6))
MMin = Application.WorksheetFunction.Max(Columns(6))
For n = LBound(arr) To UBound(arr)
If col(i) = arr(n, 4) Then
If MMax < arr(n, 1) Then MMax = arr(n, 1)
If MMin > arr(n, 1) Then MMin = arr(n, 1)
End If
Next n
arr2(i, 1) = col(i): arr2(i, 2) = MMin: arr2(i, 3) = MMax
Next i
Range("O2").Resize(UBound(arr2) + 1, 3) = arr2
End Sub
Sub Перештриховать()
ww = Int((48 * Rnd) + 1)
ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
Selection.ShapeRange.Fill.Patterned ww ' А ТАК НЕ РАБОТАЕТ
End Sub
nic44, не понял точно что нужно так как название темы не понятное вообще) транспонировать можно много ввсего у вас задача то в чем? можете своими словами ? и какой должен результат покажите.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("D2")) Is Nothing Then
If Target = Empty Then
ListObjects("озпшеница").AutoFilter.ShowAllData
Else
ActiveSheet.ListObjects("озпшеница").Range.AutoFilter Field:=2, Criteria1:=Target.Value
End If
End If
End Sub
Gnaeus Pompeius, вы бы хоть книгу показали с 5-10 строк данных...
Код
Sub drop()
Dim sFolder As String, sFiles As String
Dim i As Long, LR As Long, RV As String
With Application.FileDialog(msoFileDialogFolderPicker) 'диалоговое окно , с его помощью определяем место сохранения файлов
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
LR = Cells(Rows.Count, 1).End(xlUp).Row ' определяет последнюю ячейку со значениями в колонке
For i = 2 To LR Step 4 ' каждые 4 строки начиная со 2 по LR
RV = Cells(i, 1) 'номер отделения
Workbooks.Add ' создаёт файл
ThisWorkbook.Sheets(1).Range(Cells(i, 1), Cells(i + 3, 3)).Copy Destination:=ActiveWorkbook.Sheets(1).Range("B2") 'копирует и вставляет значения
ActiveWorkbook.SaveAs Filename:=sFolder & "BR " & RV & " Execution", FileFormat:=xlWorkbookNormal
ActiveWorkbook.Close True 'закрывает и сохраняет
Next i
End Sub