» Excel VBA (часть 3)

Frantishek

Цитата:

Ругается на вот это ("указанное значение выходит за допустимые пределы") -

в каком excel'e? у меня в 2003 работает
может так заработает
[more]
Код: Private Sub Worksheet_SelectionChange(ByVal Target _
As Excel.Range)

Dim s As Shape

Dim width As Integer
Dim color As Long
Dim trans As Single

For Each s In ActiveSheet.Shapes
If Left(s.Name, Len("selection-rect")) = "selection-rect" Then s.Delete
Next

width = 2
color = rgb(255, 0, 0)
trans = 0.8

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireRow.Left, _
ActiveCell.EntireRow.Top, _
ActiveCell.EntireRow.width, _
width)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect1"
End With

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireRow.Left, _
ActiveCell.EntireRow.Top + ActiveCell.EntireRow.Height - width, _
ActiveCell.EntireRow.width, _
width)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect2"
End With

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireColumn.Left, _
ActiveCell.EntireColumn.Top, _
width, _
ActiveCell.EntireColumn.Height)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect3"
End With

With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
ActiveCell.EntireColumn.Left + ActiveCell.EntireColumn.width - width, _
ActiveCell.EntireColumn.Top, _
width, _
ActiveCell.EntireColumn.Height)
.Fill.ForeColor.rgb = color
.Fill.Transparency = trans
.Line.Visible = False
.Name = "selection-rect4"
End With
End Sub

smirnvlad
2007, продолжает ругаться(

Frantishek
а так?
[more]
Код:
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim s As Shape

Dim lwidth As Integer
Dim lcolor As Long
Dim ltrans As Single

Dim rl(4) As Single, rt(4) As Single, rw(4) As Single, rh(4) As Single
lwidth = 2
lcolor = rgb(255, 0, 0)
ltrans = 0.8

For Each s In ActiveSheet.Shapes
If Left(s.Name, Len("selection-rect")) = "selection-rect" Then s.Delete
Next

rl(1) = ActiveCell.EntireRow.Left + 1: rl(2) = rl(1)
rt(1) = ActiveCell.Top: rt(2) = rt(1) + ActiveCell.Height - lwidth
rw(1) = ActiveCell.EntireRow.width - 2: rw(2) = rw(1)
rh(1) = lwidth: rh(2) = rh(1)

rl(3) = ActiveCell.EntireColumn.Left
rt(3) = ActiveCell.Top - 2000: If rt(3) < 1 Then rt(3) = 1
rw(3) = lwidth
rh(3) = 4000: If (rt(3) + rh(3)) > (Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height) Then rh(3) = Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height - rt(3) - 1


rl(4) = rl(3) + ActiveCell.width - lwidth
rt(4) = rt(3)
rw(4) = rw(3)
rh(4) = rh(3)

For i = 1 To 4
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, rl(i), rt(i), rw(i), rh(i))
.Fill.ForeColor.rgb = lcolor
.Fill.Transparency = ltrans
.Line.Visible = False
.Name = "selection-rect" + Trim$(Str$(i))
End With
Next

End Sub

smirnvlad
Ух ты, работает! Спасибо!
Он что-то может удалить из оформленческих причиндалов?
И подскажите плз. строки в которых можно поменять настройки цвета выделения, и толщину.. Еща раз спсб!

Frantishek

Цитата:

Он что-то может удалить из оформленческих причиндалов?

если в начале названия ваших автофигур не будет "selection-rect", то не удалит


Цитата:

подскажите плз. строки в которых можно поменять настройки цвета выделения, и толщину.. Еща раз спсб!

[more]толщина линий

Код:
lwidth = 2

smirnvlad
Спасибо

Попробовал на живой форме (у меня там структуры, фильтры и закрепленные области), и снова ошибка, уже здесь -
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, rl(i), rt(i), rw(i), rh(i))

Если я еще не надоел, то ...

Плюс, обратил внимание.. крайняя нижняя/правая черта выделения как бы немного не попадает в разметку страницы, если это не специально, то хотелось бы поправить.. Спсб!

Frantishek
а так
[more]
Код:
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim s As Shape

Dim lwidth As Integer
Dim lcolor As Long
Dim ltrans As Single

Dim rl(4) As Single, rt(4) As Single, rw(4) As Single, rh(4) As Single
lwidth = 2
lcolor = rgb(255, 0, 0)
ltrans = 0.8

For Each s In ActiveSheet.Shapes
If Left(s.Name, Len("selection-rect")) = "selection-rect" Then s.Delete
Next

rl(1) = 1
rt(1) = ActiveCell.Top
rw(1) = (Cells(ActiveCell.Row, Columns.Count).Left + Cells(ActiveCell.Row, Columns.Count).width) - 2
rh(1) = lwidth

rl(2) = rl(1)
rt(2) = rt(1) + ActiveCell.Height - lwidth
rw(2) = rw(1)
rh(2) = rh(1)

rl(3) = ActiveCell.Left
rt(3) = ActiveCell.Top - 2000: If rt(3) < 1 Then rt(3) = 1
rw(3) = lwidth
rh(3) = 4000: If (rt(3) + rh(3)) >= (Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height) Then rh(3) = Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height - rt(3) - 1

rl(4) = rl(3) + ActiveCell.width - lwidth
rt(4) = rt(3)
rw(4) = rw(3)
rh(4) = rh(3)

For i = 1 To 4
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, rl(i), rt(i), rw(i), rh(i))
.Fill.ForeColor.rgb = lcolor
.Fill.Transparency = ltrans
.Line.Visible = False
.Name = "selection-rect" + Trim$(Str$(i))
End With
Next

End Sub

Все ту же строку кода выделяет с ошибкой. Но на пустом листе (новом) ее нет, и если на новом листе все это включить (фильтр, группировка, закрепление) ошибки тоже почему то нет, значит дело не в этом, тогда уже непонятно в чем(
Про разметку не важно, это скорее от самого Экселя

есть код

Код: Public Sub Штамп()
SendKeys "Пожалуйста, дайте ответ "
SendKeys Date + 3
SendKeys ("{NUMLOCK}")
DoEvents
End Sub

aha

Код:
Public Sub Штамп()
SendKeys "Пожалуйста, дайте ответ "
curdate = Date
If Weekday(curdate + 3) = vbSaturday Then
SendKeys curdate + 5
ElseIf Weekday(curdate + 3) = vbSunday Then
SendKeys curdate + 4
Else
SendKeys curdate + 3
End If
SendKeys ("{NUMLOCK}")
DoEvents
End Sub

aha

Код:
dim strTemp as string
dim intTemp as string

intTemp=3

strTemp=TEXT(Date + intTemp, "ddd")
if strTemp="Sun" then
intTemp=4
if strTemp="Sat" then
intTemp=5
end if

SendKeys Date + intTemp

smirnvlad
спасибо, попробовал, но переводит дату все равно на выходные тоже...
dneprcomp
strTemp=TEXT выдает ошибку на этой строке

Глупый вопрос.
91-я ошибка(Object variable not set и т.д.) на строке
Set oApp = CreateObject("Shell.Application")
Переменная димнута как object
oApp As Object
Проблем в рефах нет.
Куда копать?
Заранее спасибо.

aha
Строка в коде должна быть полностью:
strTemp = TEXT(Date + intTemp, "ddd")
Если не работает, то или переменные не инициализированы, или возможно данная версия офиса не поддерживает функцию TEXT. У меня 2010.
Еще может быть Excel не может получить значение Date + intTemp внутри TEXT.

Добавил
A, фунция Date в Excel возвращает совсем не дату.
Попробуй Now:
dim TempDate as date
TempDate = Now + 3
strTemp = TEXT(TempDate, "ddd")

Вот, пару недель назад спрашивал про код, предложенный SAS888, но так пока никто и не ответил
00:34 27-08-2010
Цитата:

Если две соседние ячейки разделены границей, то она почему-то не сбрасывается этим макросом.  Наверное, эта общая граница является каким-то особым элементом оформления? А какой командой сбросить и ее тоже?

oshizelly

Код:
For Each x In Array(xlDiagonalDown, xlDiagonalUp, xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal): Selection.Borders(x).LineStyle = xlNone: Next

smirnvlad
http://zalil.ru/29641475

aha
только что проверил
сегодня 6 после выполнения получаем 09.09.2010
перевел дату на 7 - 10.09.2010
8 - 13.09.2010
9 - 13.09.2010
10 - 13.09.2010
11 - 14.09.2010
12 - 15.09.2010
разве не так должно быть?

smirnvlad 11:48 06-09-2010
Это работает. Спасибо!

Frantishek
посмотрел в 2007, теперь без ошибки
а сдвиг происходит из-за масштаба в 2007, там он по умолчанию 120%, если переключить на 100% всё ровно, как это исправить - не знаю
[more]
Код:
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim s As Shape

Dim lwidth As Integer
Dim lcolor As Long
Dim ltrans As Single
Dim Sr, Sc As Double

Dim rl(4) As Single, rt(4) As Single, rw(4) As Single, rh(4) As Single
lwidth = 6
lcolor = RGB(192, 0, 0)
ltrans = 0.9

For Each s In ActiveSheet.Shapes
If Left(s.Name, Len("selection-rect")) = "selection-rect" Then s.Delete
Next

rl(1) = ActiveCell.Left - 10000: If rl(1) < 1 Then rl(1) = 1
rt(1) = ActiveCell.Top
rw(1) = 20000: If (rl(1) + rw(1)) >= ((Cells(ActiveCell.Row, Columns.Count).Left + Cells(ActiveCell.Row, Columns.Count).Width)) Then rw(1) = (Cells(ActiveCell.Row, Columns.Count).Left + Cells(ActiveCell.Row, Columns.Count).Width) - rl(1) - 1
rh(1) = lwidth

rl(2) = rl(1)
rt(2) = rt(1) + ActiveCell.Height - lwidth
rw(2) = rw(1)
rh(2) = rh(1)

rl(3) = ActiveCell.Left
rt(3) = ActiveCell.Top - 10000: If rt(3) < 1 Then rt(3) = 1
rw(3) = lwidth
rh(3) = 20000: If (rt(3) + rh(3)) >= (Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height) Then rh(3) = Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height - rt(3) - 1

rl(4) = rl(3) + ActiveCell.Width - lwidth
rt(4) = rt(3)
rw(4) = rw(3)
rh(4) = rh(3)

Select Case ActiveWindow.Zoom
Case 110: Sr = 1.001022: Sc = 1.0227274
Case 120: Sr = 1.001872: Sc = 0.9895834
Case 130: Sr = 1.002592: Sc = 1.0096156
Case 140: Sr = 1.003207: Sc = 0.98214291
Case Else: Sr = 1: Sc = 1
End Select

For i = 1 To 4
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, rl(i) * Sr, rt(i) * Sc, rw(i), rh(i))
.Fill.ForeColor.RGB = lcolor
.Fill.Transparency = ltrans
.Line.Visible = False
.Name = "selection-rect" + Trim$(Str$(i))
End With
Next

End Sub

smirnvlad
да все работает, это я с утра тормознул...спб.

smirnvlad
Спасибо, теперь порядок!

А возможно ли соорудить макрос, который импортирует данные из файла xls, лежащего в одной папке с исходным, без указания пути?
Скажем, в коде сразу строго забиваются имена по умолчанию (файл-лист для целевого и исходного файла), и определяются массивы ячеек для синхронизации вида E5:G8;I5:J12;... (адреса также едины)
Если ответ "да", то как такое может выглядеть на примере.. Спсб.

Frantishek, запросто! Thisworkbook.Path возвращает путь к ТЕКУЩЕЙ книге, с его помощью можно открыть и другой файл, а затем считать нужные данные.

ZlydenGL
А как это в коде.. там же вроде немного строк должно получится.. Если по схеме:
-получаем путь
-обращаемся к целевому файлу-листу (переменная)+(путь)=адрес за чтением данных в массивах (переменная)
- перекидываем эти данные к себе в те же ячейки с сохранением форматов
end
(выполнение по кнопке на исходном файле)
(интересно, в 34 еще не поздно стать программистом?

Самый простой вариант, когда все данные валяются в переменных. Как заточить на динамику - думай сам


Код: Const SourceName As String = "sourcebook.xls"
Const SourceSheet As String = "data"
Const SourceFirstRow As Long = 1
Const SourceLastRow As Long = 5
Const SourceFirstCol As Byte = 1
Const SourceLastCol As Byte = 3

Dim S_WB As Workbook, I As Long, J As Byte

Set S_WB = Workbooks.Open(Thisworkbook.Path & SourceName, False, True)
S_WB.Worksheets(SourceSheet).Activate

For I = SourceFirstRow To SourceLastRow
For J = SourceFirstCol To SourceLastCol
Thisworkbook.Activesheet.Cells(1 + I - SourceFirstRow, 1 + J - SourceFirstCol) = S_WB.Cells(I, J)
Next J
Next I

ZlydenGL
Спасибо! Я вот только не понял, если данные кусочно тянуть, из разных мест на листе (типа E5:G8;I5:J12;...) и туда же вставлять, какие переменные менять?

Frantishek, тэкс, понятно... То, что файл-источник данных остается открытым, ты не углядел С программированием ВООБЩЕ раньше сталкиваться не приходилось?

В случае с кусочным подтягиванием данных есть 2 самых простых варианта:
1. Делаем промежуточный лист, на него тянем все данные, а из этого листа формулами "выкусываем" все необходимое. Подходит только для того случая, когда структура отчета-источника данных будет неизменной.
2. Используем именованные области для вытаскивания данных, и пробегаясь по всем областям книги-источника данных выкусываем данные в этих областях с записью их в книгу-приемник.

А можно теоретический вопрос? Почему данные вообще оказываются в "посреднической" книге? Может быть имеет смысл книгу-источник и книгу-приемник объединить в одну?

ZlydenGL

Цитата:

С программированием ВООБЩЕ раньше сталкиваться не приходилось?

Только на уровне Т3 и рисования фейсов в Access

Цитата:

Почему данные вообще оказываются в "посреднической" книге?

Версификация. Штука вот в чем. Есть некий Excel-документ, функционал которого (в основном учетные формы) постоянно изменяется административной стороной. Есть пользователи, которые ведут в нем записи. Необходимо реализовать подход при котором пользователи получали бы новый фейс (путем простой замены этого документа с макросами) но восстанавливали свои накопленные данные (путем импорта из старых версий). Данные представляют собой несколько фиксированных табличек на одном листе. Их адреса меняются только вглубь, по мере заполнения (т.е. построчно), вот их все и надо перекидывать в новую учетную форму, и так каждый раз, т.к. функционал дополняется возможностями, а сами формы корректируются

Добавлено:
Да, чтобы прояснить почему нельзя тупо скопировать, в силу специфики, пользователи более чем блондинистые

Т.е. пример. Был файл скажем File_12, потом вышла версия File_13. Требуется используя возможности (формы) новой версии обеспечить преемственность учета старых данных, и с этой целью перенести их в новую форму простым нажатием одной кнопки (файлы хранятся в одной папке, старые потом удаляются). Структура данных предполагается что меняться не будет (по крайней мере, какое-то продолжительное время). Но, вероятно, нет проблем чтобы потом технически также обеспечить преемственность по адресам задав параметры синхронизации, типа того, что массив E5:G8 перелетает в новой версии уже по адресу E6:G9. Как то так

Подскажите, есть ли возможность указать шрифт циферок группировки? (Например когда в шапке идут цифры 1 2 3 4), облазил весь инет не нашёл Так-же смотрел версию для печати всех частей этой темы.... Возможно ли такое? Увидел свойство:    ...OutlineFont = True; в контексте самой первой ячейки подумал что задав в ней шрифт и установив это свойство в истину, получим изменение стиля... но нет... этот вопрос касательно VBA!
Заранее спасибо!

Добрый день, Управляю Excel из другого приложения, макрос в самом Excel выполняется, но при вызове из другого приложения ругается на строчку гдя я меняю шрифт, в чём причина? (и к стати выходит сообщение об ошибке от MS BVScripts run time error)

VB {

Dim Excel
Dim MySheet

Set Excel = CreateObject("Excel.Application")
Excel.Workbooks.Add
Set MySheet = Excel.ActiveSheet
MySheet.PageSetup.FitToPagesWide = 1

With MySheet
With .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown).End(xlToRight))
.Font.Size=22 End With
End With