Добрый вечер, форумчане! Хотелось бы сделать следующее:  
В книге Билл Джелен Применение VBA и макросов в Ms Excel на с.121 есть функция, с помощью которой можно получить имя и номер цвета заливки ячейки.  
С номером проблем нет, его можно узнать с помощью цикла  
Sub tt()  
Dim i&  
For i = 1 To 56  
Cells(i, 1).Interior.ColorIndex = i  
Next  
End Sub  
А вот с именем проблемы наблюдаются в диапазоне от i=17 до 32, поскольку в этой книге не присвоены имя этим номерам.Т.е. у него идет  
Select Case myCell.Interior.ColorIndex  
Case 1  
myColor="Черный"  
IndexNum=1  
......... 'в этом промежутке все заполнено нормально  
Case 16  
myColor="Серый 50%"  
IndexNum=16  
А после этого почему-то от Case17 to Case 32 ничего нету и с  
Case33    
myColor="Голубой"    
IndexNum=33  
..........    'в этом промежутке тоже все заполнено нормально  
Case56    
myColor="Серый 80%"  
IndexNum=56  
Может у кого-то есть названия этих цветов, поскольку я хочу с помощью выше приведенного цикла вывести цвет и рядом в соседней ячейки имя цвета, например вот так  
Sub tt()  
Dim i&, arrColor()  
arrColor = Array( _  
"Черный", "Белый", "Красный", "Ярко-зеленый",....)  
For i = 1 To 56  
Cells(i, 1).Interior.ColorIndex = i  
Cells(i, 2).Value = arrColor(i - 1)  
Next i  
End Sub

Всем привет! Понимаю, что тема не новая, но что-то у меня не получается...  
Есть процедура CopyLinesPoliXY() в которой параметр arr() нужно передать процедуре  
Arrwer()  
Sub CopyLinesPoliXY()  
Dim arr()  
Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent  
Dim CodeMod As VBIDE.CodeModule  
Dim nLines As Long, ProcName As String  
Set VBProj = ActiveWorkbook.VBProject  
Set VBComp = VBProj.VBComponents("PoliXY")  
Set CodeMod = VBComp.CodeModule  
ProcName = "PoliXY"  
With CodeMod  
nLines = .ProcCountLines(ProcName, vbext_pk_Proc)  
ReDim Preserve arr(1 To nLines - 3 - 8)  
For i = 1 To nLines - 3 - 8  
   arr(i) = .Lines(i + 8, 1)  
Next i  
End With  
End Sub  
************************  
Sub Arrwer(arr() As String)  
Dim j As Long, arr(), a(), b(), c(), d()  
ReDim Preserve a(LBound(arr) To UBound(arr))  
ReDim Preserve b(LBound(arr) To UBound(arr))  
ReDim Preserve c(LBound(arr) To UBound(arr))  
ReDim Preserve d(LBound(arr) To UBound(arr))  
For j = LBound(arr) To UBound(arr)  
b(j) = Replace(arr(j, 1), "#", "")  
c(j) = Replace(b(j), ",", "*")  
d(j) = Replace(c(j), ".", ",")  
a(j) = Split(Mid(Trim(Mid(d(j), 1, Len(d(j)))), 42), "*")  
Cells(j + 1, 18).Resize(, 2) = a(j)  
Next j  
End Sub  
 
Как здесь передать arr().  
Например, раньше в процедуре Arrwer() массив arr() я брал из нужных ячеек вот так:  
arr = Range(Cells(2, 10), Cells(Rows.Count, 10).End(xlUp))  
но в данном случае это лишнее действие и его нужно правильно передать.

Здравствуйте, друзья!  
Есть у меня много графиков многих зависимостей в формате jpg, которые нужно как-то распознать, чтобы вести последующие расчеты.    
Решил сделать так:  
1) обвести зависимость с помощью инструмента рисования, например полилиния. При этом нажата кнопка запись макроса  
2)извлечь координаты, которые получились при записи макроса в таблицу для последующей обработки  
x1 y1  
x2 y2  
.....  
xk yk  
 
Sub PoliXY()  
 
   With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 215.25, 663.75)  
       .AddNodes msoSegmentLine, msoEditingAuto, 224.25, 665.25  
       .AddNodes msoSegmentLine, msoEditingAuto, 231.75, 668.25  
       .AddNodes msoSegmentLine, msoEditingAuto, 239.25, 674.25  
       .AddNodes msoSegmentLine, msoEditingAuto, 246#, 681#  
       .AddNodes msoSegmentLine, msoEditingAuto, 250.5, 687.75  
       .AddNodes msoSegmentLine, msoEditingAuto, 257.25, 698.25  
       .AddNodes msoSegmentLine, msoEditingAuto, 267.75, 715.5  
       .AddNodes msoSegmentLine, msoEditingAuto, 275.25, 727.5  
       .AddNodes msoSegmentLine, msoEditingAuto, 281.25, 733.5  
       .AddNodes msoSegmentLine, msoEditingAuto, 285#, 738#  
       .AddNodes msoSegmentLine, msoEditingAuto, 292.5, 744.75  
       .AddNodes msoSegmentLine, msoEditingAuto, 300#, 750.75  
       .AddNodes msoSegmentLine, msoEditingAuto, 303#, 753.75  
       .AddNodes msoSegmentLine, msoEditingAuto, 312.75, 759.75  
       .AddNodes msoSegmentLine, msoEditingAuto, 320.25, 763.5  
       .AddNodes msoSegmentLine, msoEditingAuto, 330.75, 768#  
       .AddNodes msoSegmentLine, msoEditingAuto, 338.25, 772.5  
       .AddNodes msoSegmentLine, msoEditingAuto, 347.25, 775.5  
       .AddNodes msoSegmentLine, msoEditingAuto, 356.25, 778.5  
       .AddNodes msoSegmentLine, msoEditingAuto, 366#, 782.25  
       .AddNodes msoSegmentLine, msoEditingAuto, 375#, 785.25  
       .AddNodes msoSegmentLine, msoEditingAuto, 381#, 788.25  
       .ConvertToShape.Select  
   End With  
End Sub  
 
Но как извлечь эти координаты пока не приходит в голову.Помогите пожалуйса, может кто-то сталкивался с подобной проблемой.

Здравствуйте, уважаемые форумчане!  
Столкнулся с одной проблемкой и не могу ее решить.  
Есть процедура, которая находится в модуле MPerenosSTR, но в скобках ее указаны аргументы  
которые нужно указать.  
Sub Макрос2(irow As Long, icol As Long)  
Range(Cells(irow, icol), Cells(Rows.Count, icol).End(xlUp)).Select  
End Sub  
На Лист3 с помощью кнопки мне нужно вызвать эту процедуру  
Private Sub CommandButton2_Click()  
MperenosSTR.Макрос2  
End Sub  
Но при вызове выдается ошибка Compile error: Argument not optional.

Здравствуйте, уважаемые форумчане! Нуждаюсь в помощи оптимизации макроса.  
Есть код, который разделяет текст по строкам    
Sub PerenosTextColumn()  
Dim rng As Range, arow As Range  
Dim j%, i%, dr%, row0%, u%, stroka$, dl&, st#  
dl = 7  
dr = 1: row0 = 18  
stroka = CStr(Cells(row0, 1).Value)  
u = Len(stroka)  
st = Round((u / dl), 0)  
Cells(row0, 1).TextToColumns Destination:=Cells(row0 + dr, 1), DataType:=xlFixedWidth, _  
FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(10, 1), Array(15, 1), Array(20, 1)), _  
   TrailingMinusNumbers:=True  
 Set arow = Range(Cells(19, 1), Cells(19, Columns.Count).End(xlToLeft))  
  j = 0: i = 0  
  For Each rng In arow.Cells  
  Cells(19 + j, 1).Value = rng  
  j = j + 1  
  Next rng  
    For Each rng In arow.Cells  
  Cells(19, i + 2).Clear  
  i = i + 1  
  Next rng  
End Sub  
Смущает строчка  
FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(10, 1), Array(15, 1), Array(20, 1))  
Как можно ее оптимизировать,когда будет  
Array(Array(0, 1), Array(5, 1),Array(10, 1),Array(15, 1),...,  , Array(n, 1)  
Пробовал искусственно сделать вот так  
Sub PerenosTextColumneeyu()  
Dim rng As Range, arow As Range, arst()  
Dim j%, i%, dr%, row0%, u%, stroka$, dl&, st#  
dl = 7  
dr = 1: row0 = 18  
stroka = CStr(Cells(row0, 1).Value)  
u = Len(stroka)  
st = Round((u / dl), 0)  
For i = 1 To u Step st - 1  
Count = Count + 1  
ReDim Preserve arst(1 To Count)  
arst(Count) = "Array(" & i - 1 & ", 1)"  
Next i  
a = Join(arst, ", ")  
Cells(4, 1).Value = a  
vv = "Array(" & a & ")"  
Cells(5, 1).Value = vv  
Cells(row0, 1).TextToColumns Destination:=Cells(row0 + dr, 1), DataType:=xlFixedWidth, _  
FieldInfo:=vv, TrailingMinusNumbers:=True  
 Set arow = Range(Cells(19, 1), Cells(19, Columns.Count).End(xlToLeft))  
  j = 0: i = 0  
  For Each rng In arow.Cells  
  Cells(19 + j, 1).Value = rng  
  j = j + 1  
  Next rng  
    For Each rng In arow.Cells  
  Cells(19, i + 2).Clear  
  i = i + 1  
  Next rng  
End Sub  
Но оно не может прочитать vv как    
Array(Array(0, 1), Array(6, 1), Array(12, 1), Array(18, 1), Array(24, 1), Array(30, 1), Array(36, 1), Array(42, 1))  
в моем случае.

Здравствуйте, форумчане!    
Прошу Вашей помощи, поскольку не могу составить функцию.  
Есть у меня функция (думаю  тоже нужно подправить)    
Function symbolicon(ByVal smb As String, ByVal dw As Double) As Double  
Select Case smb 'Cells(100, 1).Value  
Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, _  
"g", "h", "k", "x", "c", "v", "y", "u", "n", _  
"у", "к", "х", "в", "л", "я", "с", "ь"  
dw = 420 / 62  
Case "q", "o", "p", "d", "b", _  
"й", "ц", "н", "ъ", "п", "р", "о", "д", "ч", "и", "б"  
dw = 420 / 56  
Case "j", "l", "i"  
dw = 420 / 140  
Case "z", "e", "a", "s", _  
"е", "г", "з", "а", "э", "т"  
dw = 420 / 70  
Case "w", _  
"ы", "ж"  
dw = 420 / 43  
Case "m", _  
"ш", "щ", "ю"  
dw = 420 / 40  
Case "r", "f"  
dw = 420 / 93  
Case "t"  
dw = 420 / 112  
End Select  
End Function  
и есть процедура (также нужно подкорректировать)  
Sub bgh()  
stroka = Cells(1, 1).Value  
Do While n < 420  
n = 0  
For i = 1 To Len(stroka)  
k = Mid(stroka, i, 1)  
Call symbolicon(k, dw)  
n = symbolicon(k, dw) + n  
Next i  
Loop  
End Sub  
Нужно все это завязать так, чтобы работало.  
Например, есть в ячейке Cells(1, 1) текст  
sdfdfdfdfdfdfdfdfjjjjkk  
нужно, чтобы при тестировании было так  
n=6+0 и т.п.  
....

Добрый вечер, любители VBA!  
Хотелось бы реализовать перенос текстовой строки в Excel.    
Если ширина текстовой строки превышает lw1>425, остальные символы нужно перенести на ячейку в строке ниже.  
Например текст  
вавауклдщщыйзкш (>425), то будет вот так  
вавауклдщщы  
йзкш    
До переноса я пока не дошел, поскольку снова зациклился на цикле, который неправильно работает    
Sub width_rng()  
Dim i As Integer  
Cells(1, 3).EntireColumn.AutoFit  
lw1 = Cells(1, 3).Width  
slw1 = Len(Cells(1, 3).Value)  
slw2 = Len(Cells(1, 3).Value) - (Len(Cells(1, 3).Value) - 1)  
Cells(1, 4).Value = Right(Cells(1, 3).Value, 1)  
Cells(1, 4).EntireColumn.AutoFit  
lw2 = Cells(1, 4).Width  
i = 1  
Do While lw1 > 425  
ilw1 = Right(Cells(1, 3).Value, i)  
Cells(1, 3).EntireColumn.AutoFit  
lw1 = Cells(1, 3).Width  
i = i + 1  
Loop  
Cells(1, 3).ColumnWidth = 1.33  
Cells(1, 4).ColumnWidth = 1.33  
End Sub  
А именно в окне Locals lw1 остается постоянной и невозможно выйти из цикла.

Здравствуйте, уважаемые форумчане! Давно назрела задача вычислить длину строки в points.  
Например, есть код  
Sub LTextPt()  
Dim x As Double, y As Double, dwidth As Double, dheight As Double  
x = 200: y = 200: dwidth = 50: dheight = 50  
   ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, x, y, _  
       dwidth, dheight).Select  
   Selection.Characters.Text = "qwertyuiopasdfghjklzxcvbnmWINKLEWXZA"  
   With Selection.Characters(Start:=1, Length:=3).Font  
       .Name = "Times New Roman"  
       .FontStyle = "обычный"  
       .Size = 14  
       .ColorIndex = xlAutomatic  
   End With  
    With Selection  
       .HorizontalAlignment = xlLeft  
       .VerticalAlignment = xlTop  
       .ReadingOrder = xlContext  
       .Orientation = xlHorizontal  
       .AutoSize = True  
   End With  
   Selection.ShapeRange.Fill.Visible = msoFalse  
   Selection.ShapeRange.Line.Visible = msoFalse  
End Sub  
Как можно вычислить длину строки (в points)  
qwertyuiopasdfghjklzxcvbnmWINKLEWXZA  
или в простейшем случае ширину символа?  
Читал книгу Дан Эпплам Win32API и Visual Basic Глава 11. Текст и шрифты, но  функции WinAPI и как ими воспользоваться еще для меня непосильно.  
Например,  
GetTextExtentPoint32  
GetTextMetrics  
и т.п.  
Буду очень благодарен за помощь.

Всем привет!  
Составил цикл по наименованию ячеек. Получился он с трехкратным вложением.    
Вот смущает такое    
For k = 0 To 3  
Конечно, можно написать (при одинаковом количестве элементов в данных диапазонах)  
For k= LBound(phase(1)) To UBound(phase(1))  
или    
For k= LBound(phase(2)) To UBound(phase(2))    
или  
....  
For k= LBound(phase(4)) To UBound(phase(4))  
Но как быть, когда в диапазонах разное количество элементов, например  
phase(1)=Array("AbsU", "argU", "ReU", "ImU")  
phase(2)=Array("AbsI", "argI")  
.....  
phase(4)= Array("AbsY", "argY", "ReY", "радY", "двY", "шестY", "трехY")  
 
код находится в модуле YXX_Names

Здравствуйте, уважаемые гуру и просто единомышленники!  
Хотелось бы сделать следующее с помощью цикла:  
текст= текст1 & текст2 & ... т.д.  
Но не могу почмуто это сделать...  
Делаю следуюющее, но это не то, что нужно:  
Sub TCHR()  
Dim i As Integer, k As Integer, nm As Name, urng As String, rns As String  
Dim stre As String, stren As String  
stre = "Cells(13, 1),Cells(13, 11)"  
 
For i = 7 To (10 - 1) * 7 Step 7  
strek = "Cells(" & 13 + i & ", 1), Cells(" & 13 + i & ", 11)"  
 
stren = ChrW(44) & strek  
ar = stre & stren  
 
'  Range("A13:K13,A20:K20,A27:K27,A34:K34").Select  
MsgBox ar  
Next i  
' urng.Select  
End Sub  
 но никак не получается

Привет всем!  
Столкнулся с такой проблемой  
Для удобства обращения к формулам, проименовал вначале нужные диапазоны с помощью цикла  
 
Sub ROLI()  
Dim i As Integer  
Set NmDoc = ActiveWorkbook.Worksheets("Лист4").Names  
For i = 3 To 37  
NmDoc.Add Name:="Критерий_a" & i - 2, RefersToR1C1:="=Лист4!R" & i & "C39"  
 
NmDoc.Add Name:="Критерий_b" & i - 2, RefersToR1C1:="=Лист4!R" & i & "C40"  
Next i  
End Sub  
 
В формуле    
Nm.Cells(RowL, ColL).FormulaR1C1 = _  
       "=INDEX(ДиапазонРолей,MATCH(Критерий_b1,Критерий_b,0)," & _  
       "MATCH(Критерий_a1,Критерий_a,0))"  
 
Критерий_b1 должен изменять свое имя, т.е Критерий_b1, Критерий_b2,.., Критерий_bn  
 
Критерий_a1 одновремено тоже должен изменять свое имя, т.е Критерий_a1,..,Критерий_an    
Воспользовавшись циклом, написал следующее  
Sub FNAME()  
Dim i As Integer  
RowL = 3: ColL = 41  
Set Nm = ActiveWorkbook.Worksheets("Лист4")  
For i = 0 To 35  
Nm.Cells(RowL, ColL).FormulaR1C1 = _  
       "=INDEX(ДиапазонРолей,MATCH(Критерий_b & i+1,Критерий_b,0)," & _  
       "MATCH(Критерий_a & i+1,Критерий_a,0))"  
Next i  
End Sub  
 
Еще пробовал варианты, но не работает цикл, хотя при прогонке VBA никаких ошибок не выдает.

Есть ячейки rA, rB, rC, в которые вводятся данные. Хотелось бы сделать таким образом, чтобы когда я ввожу данные в любую из этих ячеек, т.е. активизирую одну из этих ячеек, срабатывало событие.  
В ниже приведенном коде эта задача решается, но здесь я задействовал еще одну ячейку rP,  
которую хотелось бы исключить. Ячейка rON_OFF здесь как индикатор, показывает включено или отключено событие.  
Private Sub Worksheet_Change(ByVal Target As Range)  
Set Nm = ActiveWorkbook.Worksheets("Лист1")  
Set rA = Nm.Cells(20, 1)  
Set rB = Nm.Cells(20, 2)  
Set rC = Nm.Cells(20, 3)  
 
Set rP = Nm.Cells(22, 4)  
Set rON_OFF = Nm.Cells(22, 5)  
 
If rP.Value = 0 Then  
Application.EnableEvents = False  
  rON_OFF.Value = "ON"  
  TREN  
  YXX_Run.Param  
Application.EnableEvents = True  
Else  
  rON_OFF.Value = "OFF"  
  Exit Sub  
End If  
End Sub

Столкнулся с одной проблемой. Excel не может вычислить, например определитель (МОПРЕД) или обратную матрицу (МОБР) и т.п., где аргументами будут комплексные числа. Выдает мне ошибку #ЗНАЧ!, а VBA выдает сообщение 1004 "Нельзя установить свойство FormulaArray класса Range"  
Приведу код VBA  
Sub Complex_matrix()  
Set NmForm = ActiveWorkbook.Worksheets("Лист3").Names  
 
   NmForm.Add Name:="MdU", RefersToR1C1:="=Лист3!R28C2:R29C3"  
   NmForm.Add Name:="dU", RefersToR1C1:="=Лист3!R28C4:R29C5"  
 
Worksheets("Лист3").Range("MdU").FormulaArray = "={КОМПЛЕКСН(2;3),КОМПЛЕКСН(1;2);КОМПЛЕКСН(4;6),КОМПЛЕКСН(4;1)}"  
Worksheets("Лист3").Range("dU").FormulaArray = "=MINVERSE(MdU)"  
End Sub  
 
Неужели в Excel нельзя вычислить комплексную матрицу? В книге Ф.Р. Гантмахера "Теория Матриц"  матрицу, агрументами которой являются комплексные числа можно вычислить. Но в справке по Excel не написано каких-то ограничений на эту тему.