Из столбца с названием предприятия и несколькими его адресами извлечь с повтором название предприятия., Помощь при обработке данных Excel/Данные таблицы Excel
Sub myFill()
ActiveSheet.Copy
Dim rr As Range
Set rr = Intersect(Selection, ActiveSheet.UsedRange)
Selection.EntireColumn.Columns(1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Dim rb As Range
Dim cl As Range
For Each cl In rr.Columns(1).Cells
Debug.Print cl.Value
If cl.Font.Bold Then
Set rb = cl
End If
If Not rb Is Nothing Then
rb.Copy cl.Offset(, -1)
End If
Next
rb.Offset(, -1).EntireColumn.AutoFit
End Sub
Function МАКСНЕПУТЫХ(Диапазон As Range) As Long
Dim arr As Variant
arr = Диапазон
Dim res As Long
Dim nn As Long
Dim ya As Long
Dim xa As Long
Dim x1 As Long
Dim x2 As Long
For ya = 1 To UBound(arr, 1)
For x1 = 1 To UBound(arr, 2)
If Not IsEmpty(arr(ya, x1)) Then Exit For
Next
For x2 = UBound(arr, 2) To 1 Step -1
If Not IsEmpty(arr(ya, x2)) Then Exit For
Next
nn = 0
For xa = x1 To x2
If IsEmpty(arr(ya, xa)) Then
nn = nn + 1
If res < nn Then res = nn
Else
nn = 0
End If
Next
Next
МАКСНЕПУТЫХ = res
End Function
=ЕСЛИОШИБКА(ЕСЛИ(ВПР(A:A;'[ФАЙЛ НОМЕР 2.xlsx]Лист1'!$A:$D;3;0)="";ВПР(A:A;'[ФАЙЛ НОМЕР 2.xlsx]Лист1'!$A:$D;4;0);ВПР(A:A;'[ФАЙЛ НОМЕР 2.xlsx]Лист1'!$A:$D;3;0));"")
Sub myIncrement()
Dim yy As Long
yy = GetY(Range("AB1").Value)
If yy = 0 Then Exit Sub
Range("AB1").Value = GetKeyRange().Cells(yy + 1, 1).Value
End Sub
Sub myDecrement()
Dim yy As Long
yy = GetY(Range("AB1").Value)
If yy < 2 Then Exit Sub
Range("AB1").Value = GetKeyRange().Cells(yy - 1, 1).Value
End Sub
Private Function GetY(vValue As Variant)
On Error Resume Next
GetY = WorksheetFunction.Match(vValue, GetKeyRange(), 0)
On Error GoTo 0
End Function
Private Function GetKeyRange() As Range
Set GetKeyRange = Sheets("Данные АОСР").ListObjects("Данные_для_АОСР").ListColumns("KEY").DataBodyRange
End Function
написал: Это вариант, так называемого, репроцитного обмена, широко распространенного на ранних стадиях эволюции человеческих сообществ. Почему не вернуться к нему - т.е. Безденежно. Хотя бы в некоторых нетривиальных ситуациях.
Да, были времена! Здорово, наверное, было. Взял поменялся с кем-то репроцитно, и ходишь довольный. Жаль, конечно, что никак не вернуться к "репроцитному обмену"... Вот вы удивитесь, заглянув в ветку Вопросы по Microsoft Excel (planetaexcel.ru). В простонародье её называют бесплатной, но вы можете называть "репроцитной".
Вариант через пользовательскую функцию. Это в стандартный модуль. Alt+F11
Код
Option Explicit
Public Function РАЗДЕЛИТЬ(Строка As String, Индекс_начало As Long, Индекс_конец As Long) As Variant
Const DLM = "-"
If InStr(Строка, DLM) = 0 Then
РАЗДЕЛИТЬ = Строка
Else
Dim arr As Variant
arr = Split(Строка, DLM)
ReverseIndex Индекс_начало, UBound(arr)
ReverseIndex Индекс_конец, UBound(arr)
Dim brr As Variant
ReDim brr(Индекс_начало To Индекс_конец)
Dim yb As Long
For yb = LBound(brr) To UBound(brr)
brr(yb) = arr(yb)
Next
РАЗДЕЛИТЬ = Join(brr, DLM)
End If
End Function
Private Sub ReverseIndex(ind As Long, iUbo As Long)
If ind < 0 Then
ind = iUbo + ind + 1
Else
ind = ind - 1
End If
End Sub
Вариант макросом. Выделите ячейки, которые требуется разделить, в вашем случае это столбец C, запустите макрос SplitSelection.
Код
Option Explicit
Private Const CH = ";"
Sub SplitSelection()
SplitRange Selection
End Sub
Private Sub SplitRange(rn As Range)
Dim Application_Calculation As XlCalculation
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Set rn = Intersect(rn, rn.Parent.UsedRange)
Dim arr As Variant
Dim ya As Long
Dim cl As Range
For Each cl In rn.Cells
If InStr(cl.Value, CH) > 0 Then
arr = Split(cl.Value, CH)
For ya = UBound(arr) To LBound(arr) + 1 Step -1
cl.EntireRow.Copy
cl.EntireRow.Rows(2).Insert
cl.Cells(2, 1).Value = Trim(arr(ya))
Next
cl.Value = Trim(arr(ya))
End If
Next
Application.CutCopyMode = False
Application.Calculation = Application_Calculation
End Sub
Для типа диаграммы "Точечная" масштаб можно менять макросам, приведёнными ниже. Для гистограммы из вашего примера, видимо, надо менять диапазон данных.
Код
Sub Уменьшить()
On Error Resume Next
Dim sp As ChartObject
For Each sp In ActiveSheet.ChartObjects
With sp.Chart.Axes(xlCategory)
.MaximumScale = .MaximumScale - 1
End With
Next
End Sub
Sub Увеличить()
On Error Resume Next
Dim sp As ChartObject
For Each sp In ActiveSheet.ChartObjects
With sp.Chart.Axes(xlCategory)
.MaximumScale = .MaximumScale + 1
End With
Next
End Sub