Всё норм. Формула требуется для противодействия злобному гению(ученику пятого класса Андрею Иванову), обладающего знаниями, позволяющими взломать пароль
Как можно было бы сделать. - Сделать таблицу соответствия географических координат и координат на экране. Например, через каждые 5000 км по параллелям и меридианам. - Новые координаты на экране получать используя эти данные, например, с помощью линейной аппроксимации.
PS Точность метода может оказаться небольшой - на дубль в платной ветке не тороплюсь откликаться. Возможно, кто-то предложит вариант лучше.
Sub ReplaceFormula()
'Выделите ячейки. Запустите макрос.
Const formula_was = "ЕСЛИ($AC$1=""ДВС"";СУММЕСЛИМН('Расстановка ГШО'!$BI:$BI;'Расстановка ГШО'!$Q:$Q;$C5)/('Расстановка ГШО'!$BI$2-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)))*($D5-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)));СУММЕСЛИМН('Расстановка ГШО'!$BJ:$BJ;'Расстановка ГШО'!$Q:$Q;$C5)/('Расстановка ГШО'!$BI$2-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)))*($D5-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0))))"
Const formula_must = "A2"
Dim Application_Calculation As XlCalculation
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim cl As Range
For Each cl In Selection.SpecialCells(xlCellTypeFormulas).Cells
If InStr(cl.FormulaLocal, formula_was) > 0 Then
cl.FormulaLocal = Replace(cl.FormulaLocal, formula_was, formula_must)
End If
Next
Application.Calculation = Application_Calculation
End Sub
Сравнение диапазонов на соответствие с возвратом текста после разделителя, Нужно сравнить диапазоны на совпадение и записать текст после разделителя в ячейку формулы
Sub DeleteEmptyRows()
CloseEmptyWb
ActiveSheet.Copy
Dim rSelect As Range
Set rSelect = Intersect(Selection, ActiveSheet.UsedRange)
Dim rEntRow As Range
Set rEntRow = Intersect(rSelect.EntireRow, ActiveSheet.UsedRange)
Dim aSelect As Variant
Dim aEntRow As Variant
Dim oEntRow As Variant
aSelect = GetArrayFromRange(rSelect)
aEntRow = GetArrayFromRange(rEntRow)
ReDim oEntRow(1 To UBound(aEntRow, 1), 1 To UBound(aEntRow, 2))
Dim flag As Boolean
Dim xa As Long
Dim ya As Long
Dim yo As Long
For ya = 1 To UBound(aSelect, 1)
flag = False
For xa = 1 To UBound(aSelect, 2)
If Not IsEmpty(aSelect(ya, xa)) Then
flag = True
Exit For
End If
Next
If flag Then
yo = yo + 1
For xa = 1 To UBound(aEntRow, 2)
oEntRow(yo, xa) = aEntRow(ya, xa)
Next
End If
Next
rEntRow = oEntRow
End Sub
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
Private Function GetArrayFromRange(rr As Range) As Variant
Dim arr As Variant
If rr.Cells.CountLarge = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rr.Value
Else
arr = rr.Value
End If
GetArrayFromRange = arr
End Function
Выделите диапазон, в данном случае F2:L21, запустите макрос.
Function РАБДЕНЬ_ПЛЮСПРАЗД(нач_дата As Date, число_дней As Long, праздники As Range, рабочие_выходные As Range) As Date
Dim flag As Boolean
Dim dt As Date
Dim ii As Long
dt = нач_дата
Do
If ii >= число_дней Then Exit Do
dt = dt + 1
If WorksheetFunction.CountIfs(праздники, dt) > 0 Then
flag = False
ElseIf WorksheetFunction.CountIfs(рабочие_выходные, dt) > 0 Then
flag = True
ElseIf WorksheetFunction.Weekday(dt, 2) > 5 Then
flag = False
Else
flag = True
End If
If flag Then ii = ii + 1
Loop
РАБДЕНЬ_ПЛЮСПРАЗД = dt
End Function
Sub AddSumRows()
Dim Application_Calculation As XlCalculation
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
CloseEmptyWb
ActiveSheet.Copy
AddSumRows_sheet ActiveSheet
Application.Calculation = Application_Calculation
End Sub
Private Sub AddSumRows_sheet(sh As Worksheet)
Dim xa As Long
xa = GetCashNumberColumn(sh)
With sh
Dim ya As Long
ya = .Cells(.Rows.Count, xa).End(xlUp).Row
If ya = 1 Then
CloseEmptyWb
Exit Sub
End If
Dim arr As Variant
arr = .Cells(1, xa).Resize(ya).Value
End With
AddSumRows_Array arr, sh, xa
End Sub
Private Function GetCashNumberColumn(sh As Worksheet) As Long
Dim xx As Long
On Error Resume Next
xx = sh.UsedRange.Find("№ кассового документа").Column
On Error GoTo 0
If xx = 0 Then xx = [G1].Column
GetCashNumberColumn = xx
End Function
Private Sub AddSumRows_Array(arr As Variant, sh As Worksheet, xa As Long)
Dim yb As Long
Dim ya As Long
For ya = UBound(arr, 1) To 1 Step -1
For yb = ya - 1 To 1 Step -1
If arr(yb, 1) <> arr(ya, 1) Then
Exit For
End If
Next
yb = yb + 1
If yb < ya Then
AddSumRows_Row sh, ya + 1, xa, arr(ya, 1), ya - yb + 1
ya = yb
End If
Next
End Sub
Private Sub AddSumRows_Row(sh As Worksheet, ya As Long, xa As Long, vVal As Variant, yd As Long)
With sh
.Rows(ya).Insert
.Cells(ya, 1).Resize(1, xa - 1).Merge
.Cells(ya, 1).Value = "Итого: "
.Cells(ya, xa).Resize(1, 2).Merge
.Cells(ya, xa).Value = vVal
.Cells(ya, xa + 2).FormulaR1C1 = "=SUM(R[-1]C:R[-" & yd & "]C)"
.Cells(ya, 1).Resize(1, xa + 2).Font.Bold = True
End With
End Sub
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
'v2
Sub myFormat()
FormatSheet ActiveSheet
End Sub
Private Sub FormatSheet(sh As Worksheet)
JobName sh, "Статус", True, False
JobName sh, "Подразделение", False, True
End Sub
Private Sub JobName(sh As Worksheet, ByVal sName As String, blueMode As Boolean, boldMode As Boolean)
Dim rn As Range
Set rn = GetNameRange(sName, sh)
If rn Is Nothing Then Exit Sub
With sh
Dim arr As Variant
arr = .Range(.Cells(1, rn.Column), .Cells(.UsedRange.Row + .UsedRange.Rows.Count, rn.Column))
Dim cl As Range
Dim ya As Long
For ya = rn.MergeArea.Row + rn.MergeArea.Rows.Count To UBound(arr, 1) - 1
If Not IsError(arr(ya, 1)) Then
Set cl = .Cells(ya, rn.Column)
Set cl = Intersect(cl.EntireRow, .UsedRange)
If blueMode Then
Select Case arr(ya, 1)
Case "", "ПК"
cl.Font.Color = RGB(0, 0, 0)
Case Else
cl.Font.Color = RGB(51, 153, 255)
End Select
End If
If boldMode Then
If arr(ya, 1) <> arr(ya + 1, 1) Then
With cl.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
' Else
' With cl.Borders(xlEdgeBottom)
' .LineStyle = xlContinuous
' .ColorIndex = xlAutomatic
' .TintAndShade = 0
' .Weight = xlThin
' End With
End If
End If
End If
Next
End With
End Sub
Private Function GetNameRange(sName As String, sh As Worksheet) As Range
Dim yr As Long
Dim xr As Long
On Error Resume Next
With sh
For yr = .UsedRange.Row To .UsedRange.Row + .UsedRange.Rows.Count - 1
xr = WorksheetFunction.Match(sName, .Rows(yr), 0)
If xr > 0 Then
Set GetNameRange = .Cells(yr, xr)
Exit For
End If
Next
End With
On Error GoTo 0
End Function