» Excel VBA (часть 3)

nic_name
Не совсем понятно, что значит 3 подстроки. Нужен пример.

Цитата:

nic_name
Не совсем понятно, что значит 3 подстроки. Нужен пример.

Например:

Скажем, тот же элемент массива
А(17) = Вополеберёзонькастояла
а
В(17) = (6,16,22)

Тогда первая "подстрока" это (отсчитываем первые 6 символов): Вополе
вторая "подстрока" это (отсчитываем с 7-го по 16 символы: берёзонька
третья "подстрока" это (отсчитываем с 17 по 22-й символы): стояла

Как-то так.

Код: Dim a(1 To 20), b(1 To 20, 0 To 20)
a(17) = "ВополеБерёзонькаСтояла"
b(17, 0) = 0
b(17, 1) = 6
b(17, 2) = 16
b(17, 3) = 22
i = 17 'строка
For n = 1 To 3 'номер подстроки
ДлинаПодстроки = b(i, n) - b(i, n - 1)
НачалоПодстроки = b(i, n - 1) + 1
MsgBox Mid(a(i), НачалоПодстроки, ДлинаПодстроки)
Next

Ай, спасибо тебе, добрый человек!

День добрый.
Делаю в екселе таблицу, в которой будут картинки. Весь проект описывать не буду, проблема у меня в следующем. Все картинки у меня с настройкой "перемещать, но не изменять размеры". Как у всех продуктов микрософт, время от времени ексель колбасит, а рисунки плющит. То есть, меняется соотношение размеров рисунка ширина к высоте. Сделал кнопку, которая возвращает размеры всех рисунков к первоначальному состоянию: 100%*100%:
Код: Sub Reset_picture_size(object As Variant)
Dim sp As ShapeRange
Select Case TypeName(object)
Case Is = "OLEObject"
Set sp = object.ShapeRange
Case Is = "Picture"
Set sp = object.ShapeRange
Case Else
Exit Sub
End Select
sp.ScaleHeight 1, msoTrue ' 100% X scale
sp.ScaleWidth 1, msoTrue ' 100% Y scale
End Sub

nick7inc
Может как то так?

Код: Sub test()
Dim oSp As Shape

For Each oSp In Worksheets(1).Shapes
If oSp.Height <> oSp.Width Then
oSp.ScaleHeight 1, msoTrue ' 100% X scale
oSp.ScaleWidth 1, msoTrue ' 100% Y scale
End If
Next
End Sub

andrewkard1980
Нет, этот код срабатывает для всех картинок, у которых ширина и высота - разные. И вовсе не обязательно у них будут разные масштабные коэффициенты.

P.S. Грубо говоря, если дважды запустить этот код, то он оба раза сделает абсолютно всё то же самое, хотя второй раз он должен пропустить все картинки, т.к. у них уже сброшены на 1 масштабные коэффициенты.

Добрый день. Может кто знает, почему макрос, взятый из справки Excel 2010

Код: Option Explicit
Public Sub test2()
Dim myDocument As Variant, s As Variant
Set myDocument = Worksheets(1)
For Each s In myDocument.Shapes
Select Case s.Type
Case msoEmbeddedOLEObject, _
msoLinkedOLEObject, _
msoOLEControlObject, _
msoLinkedPicture, msoPicture
s.ScaleHeight 1, msoTrue
s.ScaleWidth 1, msoTrue
Case Else
's.ScaleHeight 1.75, msoFalse
's.ScaleWidth 1.75, msoFalse
End Select
Next
End Sub

Цитата:

вылетает с ошибкой в Excel 2010

данные обьекты типа "msoEmbeddedOLEObject" и у них нет метода/свойства ScaleHeight

Хорошо, допустим. Мне надо у картинки или у OLE - объекта сбросить масштаб по X и Y на 100% от исходного. В 2003 оффисе этот пример работает. В 2010 - нет. Как быть? Ручками можно сделать, через свойства изображения. Как сделать макросом?

И вообще, ПОЧЕМУ пример из справки не работает?

Добавлено:
Похоже, что этот баг тянется ещё со времён MsOffice 2007.

Цитата:

Похоже, что этот баг тянется ещё со времён MsOffice 2007

nick7inc
Ваш пример в Excel 2007 работает без ошибок.

Офис 2010 - лицензионный, обновления все стоят.
Похоже, что в 2007 его исправили, Я давал ссылку на описание SP1, в котором данная ошибка указана. Про 2010 забыли.

Что там у тебя за второй объект ? Удали его, и никаких багов..

CompaEd
Ха! "Нет человека, нет проблем".
Мне надо проверить этот код для объектов 2х типов: OleObject и Picture. Если так пойдёт, то лучше целиком файл стереть и все дела.

Да, кстати, преобразовывать OleObject в Picture не предлагать.

Добавлено:
Пока сделал так ("все нормальные герои всегда идут в обход" ).

[more=Далее]В другом файле код каким-то чудом заработал,хотя и не без глюков. Если все картинки перебирать (For Each oo In Common_list.OLEObjects), то можно сбросить размеры на нужные, но если задать OleObject прямо при помощи Set - вылетает та же ошибка.Короче - барахлит бейсик с этой функцией. Поэтому приходится проверять на вылет и в этом случае запускать поиск всех OleObject, с выбором нужного по имени.


Код: Public Sub correct_all()

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim oo As Variant
For Each oo In Common_list.OLEObjects
If Right(oo.name, 6) <> "Button" Then
Reset_picture_size oo
End If
Next oo

For Each oo In Common_list.Pictures
If Right(oo.name, 6) <> "Button" Then
Reset_picture_size oo
End If
Next oo

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub


Sub Reset_picture_size(object As Variant)

Select Case TypeName(object)
Case Is = "OLEObject"
Scale_picture object, 1
Case Is = "Picture"
Scale_picture object, 1
Case Else
Exit Sub
End Select

Dim f1 As Double, f2 As Double, factor As Double
f1 = object.Width / picture_max_width
f2 = object.Height / picture_max_height
If f1 < 1 Then f1 = 1
If f2 < 1 Then f2 = 1

If f1 > f2 Then factor = 1 / f1 Else factor = 1 / f2

If factor <> 1 Then
Scale_picture object, factor
End If
End Sub

Public Sub Scale_picture(picture As Variant, factor As Double, Optional norecursion As Boolean = False)
If TypeName(picture) <> "Picture" And TypeName(picture) <> "OLEObject" Then Exit Sub
Select Case picture.ShapeRange.Item(1).Type
Case msoEmbeddedOLEObject, _
msoLinkedOLEObject, _
msoOLEControlObject, _
msoLinkedPicture, msoPicture
On Error GoTo err1
picture.ShapeRange.Item(1).ScaleHeight factor, msoTrue
picture.ShapeRange.Item(1).ScaleWidth factor, msoTrue
On Error GoTo 0
Case Else
Exit Sub
End Select
Exit Sub
' -----------------------------------------------------------------------
err1:
On Error GoTo 0
If Application.Version = 14# And Not (norecursion) Then GoTo err2
fault2:
If resize_bug_message_displayed = True Then Exit Sub
resize_bug_message_displayed = True
MsgBox "Ваша версия MsOffice не поддерживает" + Chr$(13) + _
"изменение масштаба картинки с помощью макроса." + Chr$(13) + _
"(affected MsOffice 2007-2010). Для сброса размера" + Chr$(13) + _
"всех картинок загрузите этот файл в более" + Chr$(13) + _
"ранней версии оффиса или установите обновление.", vbExclamation, "Слава, Microsoft!"
Exit Sub
err2:
Dim name As String, oo As Variant
name = picture.name
For Each oo In Common_list.OLEObjects
If oo.name = name Then Scale_picture oo, factor, True: Exit Sub
Next oo
GoTo fault2
End Sub

CompaEd, nick7inc можно использовать свойство обьекта OLE "Height" или "Width", т.е. например
Код: s.Height=s.Height*1,1

nick7inc
Проверил твой код, на виртуальной XP (под VMWare) на 2007 оффисе х32 - работает на обоих объектах... Мда-с? похоже MS лепит новые баги на старых, ровных местах... У меня например оказалось что фунция VBA - Application.Speech.Speak "Далее по русски" инициализирует голосовой движок винды в начальное "английское" состояние и естественно тишина... Исправить невозможно, команд инициализации просто нет...На 2007 все работало... Эх, где 2007 оффис x64 ???

psiho

Цитата:

если необходимо увеличить масштаб на 10%

Спасибо, про это я знаю. Мне надо масштаб править от исходного размера картинки, поскольку у офиса есть ещё один идиотизм - непредсказуемо изменять размер картинки (галка, запрещающая изменения размера стоит) с потерей пропорций. Поэтому мне надо вернуть картинку(ки) в первоначальное состояние, то есть в размер 100% от исходного по ширине и высоте, а только уже потом их уменьшить, если слишком большие получаются.

Добавлено:
CompaEd

Цитата:

Проверил твой код, на виртуальной XP (под VMWare) на 2007 оффисе х32

Спасибо, буду знать, что там работает (наверное, с SP1 тестировали).

Ещё один баг:

Код: Set oo = Common_list.OLEObjects(ObjectName)
If oo.name <> ObjectName Then Stop

nick7inc

Цитата:

Спасибо, буду знать, что там работает (наверное, с SP1 тестировали).

Вообще то: Microsoft® Office Excel® 2007 (12.0.6665.5003) SP3 MSO (12.0.6662.5000)
Для информации...

Пытаюсь штатными экселевскими средствами построить формулу для вычислений данных, но мне сложно её составить и вот почему. Сама суть такая:
Если в ячейке g4 стоит X, то в ячейке I3 поставить значение 3, если g5=x, то в ячейке j3 поставить 2, если g6=X, то в ячейке k3=2, если g7=X, то к значению ячейки j3 прибавить 3, если g8=X, то к значению ячейки k3 прибавить 2.
Но дело в том,что , например , в ячейке j3 может быть и пусто. тут зависит от ответа респондента. Так вот если там пусто, а в ячейке g7 поставлен Х, то появится ли в пустой ячейке j3 значение 3?
Есть ли скрипт, который позволял бы эту формулу составить с учетом пустой ячейки?

Подскажите код плз.
Есть выделенный блок, в нем есть строки OutlineLevel 1 и 2, нужно для разных уровней вложенности задать разное форматирование, например шрифта, границ и заливки.
Если ячейка второго столбца (B,i) в каждой строке пустая, то с этой строкой вообще ничего не делать

Вопрос снят разобрался.

Fsp050

Цитата:

в ячейке j3 может быть и пусто

в ячейке j3 будет то, что Вы установите в формуле:
=ЕСЛИ(G4="Х";3;0)+ЕСЛИ(G7="Х";3;0)

>> Fsp050
Думаю такой макрос справится
Код: If Range("G4").Value = "X" Then Range("I3").Value = 3 Else Range("I3").Value = ""
If Range("G5").Value = "X" Then Range("J3").Value = 2 Else Range("J3").Value = ""
If Range("G6").Value = "X" Then Range("K3").Value = 2 Else Range("K3").Value = ""
If Range("G7").Value = "X" Then Range("J3").Value = Range("J3").Value + 3 'Else Range("J3").Clear
If Range("G8").Value = "X" Then Range("K3").Value = Range("K3").Value + 2 'Else Range("K3").Clear

Знатоки, как можно решить следующий вопрос,
Имеется Workbook.Sheet("DT") с колонами данных, допустим 2мя (А и B), и миллионом строк (т.е. Range("A1:B1000000")
Первая колонна в формате 20110903 (т.е. год, месяц, число), вторая - неважно, текст/количественные данные или что-то ещё.
Задача: Раскидать весь лист в отдельные файлы по месяцам не обращая внимания на число (т.е. по маске 201109,201110,...201309) и не меняя данные но
>> Название файлов и листов по маске (т.е. 201109,201110,...201309) элементарно через.
'-----
wbk=Workbook.Add
Application.DisplayAlerts = False
Worksheets(1).Name = variablemask
With wbk
.SaveAs Filename:="C:\v\" & variablemask & ".xls"
.Close
End With
Application.DisplayAlerts = True
'-----
>> Первая строка каждого файла/листа содержт заголовок (напр. <date> , <value>) .. здесь тоже просто Range("A1:B1")=Array("<date>", "<value>")
Проблема: Не получается реализовать алгоритм выбора данных из исходного массива.
Пробовал и Instr и циклы, и фильтры типа Range("A1:B1000000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C2"), Unique:=True
Хиелп плиз

П.С. Например исходные данные-результат:[more]
20090201 55
20090215 24
20090402 32
20090424 48
20110319 12
20110329 19
20111005 87
20130607 41
20130612 68

На выходе нужны будут
файл 200902.xls
20090201 55
20090215 24

файл 200904.xls
20090402 32
20090424 48

файл 201103.xls
20110319 12
20110329 19

файл 201110.xls
20111005 87

файл 201306.xls
20130607 41
20130612 68[/more]

Можно через ADO
[more]

Код:
Private Function GetConnection() As Object
Dim pConn As Object
Dim sConn As String
sConn = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & ThisWorkbook.FullName
sConn = sConn & ";Extended Properties=""Excel 12.0;HDR=YES"";"
Set pConn = CreateObject("ADODB.Connection")
pConn.Open sConn
Set GetConnection = pConn
End Function

Public Sub CopyByMonth()
Dim pConn As Object, pRSmonthes As Object
Dim newBook As Workbook, newSheet As Worksheet
Dim sSQL As String, tableName As String
tableName = " [" & ThisWorkbook.ActiveSheet.Name & "$] "
sSQL = "Select Distinct Mid(CStr([Date]),1,6) From" & tableName & "Order By Mid(CStr([Date]),1,6)"
Set pConn = GetConnection
Set pRSmonthes = CreateObject("ADODB.Recordset")
pRSmonthes.CursorLocation = 3
pRSmonthes.Open sSQL, pConn
Do Until pRSmonthes.EOF
Set newBook = Application.Workbooks.Add(xlWBATWorksheet)
Set newSheet = newBook.Worksheets(1)
newSheet.Name = pRSmonthes(0).Value
newSheet.Range("A1:B1").Value = Array("Date", "Value")
newSheet.Range("A2").CopyFromRecordset pConn.Execute("Select * From" & tableName & "Where Mid(CStr([Date]),1,6)='" & newSheet.Name & "'")
pRSmonthes.MoveNext
Loop
pRSmonthes.Close: pConn.Close
End Sub

Уважаемые спецы, помогите слепить простенький скрипт, который вызывал бы окно ввода, куда пользователь мог бы ввести размер шрифта в пунктах для присвоения выделенным (или если ничего не выделено, то текущей) ячейке.

И чуть более сложный вопрос. Когда-то здесь выкладывался скрипт, который копировал все свойства исходной ячейки в буфер обмена и затем оттуда переносил их на целевую ячейку (текущую или несколько выделенных).
А можно ли сделать так, чтобы копировать/переносить не всё свойства ячейки полностью, а только некоторые? Точнее, надо переносить те параметры, которые задаются на первой вкладке штатного диалога форматирования ячейки: формат данных, например, дата, причём в определённом формате.
А шрифт, цвет заливки, выравнивание и т.п. - это всё оставалось бы без изменений. Или так не получится?

Спасибо!

oshizelly
1. Можно так:
Код: Selection.Font.Size = InputBox("Введите число", "Размер шрифта")

SAS888 02:53 01-10-2013
Цитата:

1. Можно так:

Код: Selection.Font.Size = InputBox("Введите число", "Размер шрифта")

Вот основные свойства ячейки

Код: With Range("A1")
.NumberFormat = "dd.mm.yy;@"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False

.Font.Name = "Cambria"
.Font.FontStyle = "Обычный"
.Font.Size = 12
.Font.Strikethrough = False
.Font.Superscript = False
.Font.Subscript = False
.Font.OutlineFont = False
.Font.Shadow = False
.Font.Underline = xlUnderlineStyleNone
.Font.ThemeColor = xlThemeColorLight1
.Font.TintAndShade = 0
.Font.ThemeFont = xlThemeFontMajor
End With

AndVGri
спасибо, попробую освоить, хотя по аналогии путь переноса в SQL/DB почему-то сам поленился прорабатывать, думал что-то коротче есть.

oshizelly
Кнопки наиблее часто необходимых операций выносятся на панели инструментов
то-же и с макросами, тогда можно и комбинации клавиш прицепить.
Простейший вариант если застрял можно через Macros Recorder сделать и приспособить опции как нужно, например.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False