» Excel VBA (часть 3)

Да я уже допетрил 226х312 там в пикселях походу

Public Sub CustomSize()
Dim pComment As Comment
If ActiveCell.Comment Is Nothing Then
Set pComment = ActiveCell.AddComment("")
Else
Set pComment = ActiveCell.Comment
End If
pComment.Shape.Width = 226: pComment.Shape.Height = 312
End Sub

Вот так создается новое пустое примечание размером 11х9 см

Спасибо большое AndVGri! А то в ручную мучился

sergei99959
Не-не-не! Немного не так. МС там вроде бы свои единицы применяет.

Блин, странно, но у меня только один вариант кода вставился в исходном посте. Тот, в котором используется масштабирование в указанное число раз. И описание не вставилось.

Вот второй вариант - с явным указанием размера в этих условных единицах:

надо после строк
.ScaleWidth ...
.ScaleHeight ...

добавить
.Width = 96
.Height = 55.5

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

Вот эти W x H = 96 x 55.5 = 3.39 х 1.96 см у меня при разрешении 1280х1024,
а у себя считай сам :)

Ну лично у меня, как я выше написал, всё заработало

sergei99959
Единица 1/72 дьюма, пиксель не причём

sergei99959

Цитата:

Ну лично у меня, как я выше написал, всё заработало

Вот и отлично. А я совсем выпустил из виду, что тебе и создавать еще надо, а не только менять существующее. Да и вариант AndVGri с Active.Cell повеселее будет, чем мой с ограничением на выделение лишь одной ячейки.

А размер указывется в пунктах: 1 point = 1/28 cm (1/72 inch). Если надо в пикселях, то надо пересчитывать через используемое DPI (стандартно 96).

Цитата:

unit4
По моему, я уже советовал воспользоваться xbaseview (как плагин к Total commander, так и отдельная программа).
Вот что получается
Оставил Visual Foxpro из-за того, что он позволяет корректно задать число знаков после запятой для Numeric, в отличии от Jet.OLEDB.4 (правда пришлось делать перекодировщик из Win в DOS.

Спасибо, все получилось.

P.S. только только руки дошли посмотреть.

Добрый вечер, прошу помочь решить такой вопрос: надо с задаваемым интервалом времени экспортировать лист экселя в файл формата ТХТ.
Я в ВБА нуль, но с помощью макрорекордера и гуглей соорудил такую конструкцию:

UserFrom1:

Public StartStop As Integer

Private Sub CommandButton1_Click()
Dim PauseTime, Start
PauseTime = UserForm1.TextBox1.Value
StartStop = 1
Do While StartStop = 1
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\Admin\Рабочий стол\List_ Excel.txt", FileFormat:= _
xlText, CreateBackup:=False
Loop
End Sub

Private Sub CommandButton2_Click()
StartStop = 2
Unload Me
End Sub


Module1:

Sub EXPORT()
UserForm1.Show
End Sub

Работает, но перед каждым действием появляется окно с предупреждением что такой файл уже существует, и вопросом:экспортировать?
Можно как то поменять код, чтобы запись происходила автоматически поверх существующего файла? Имя экспортируемого файла менять нельзя.

amkaz
Попробуйте

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= "C:\Documents and Settings\Admin\Рабочий стол\List_ Excel.txt", _
FileFormat:= xlText, CreateBackup:=False
Application.DisplayAlerts = True

Ребят, помогите, пожалуйста, чайнику в vba со следующим кодом -


Код: Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim LLoop As Integer
Dim LTestLoop As Integer

Dim Lrows As Integer
Dim LRange As String
Dim LChangedValue As String
Dim LTestValue As String

'Test first 200 rows in spreadsheet for uniqueness
Lrows = 200
LLoop = 2

'Check first 200 rows in spreadsheet
While LLoop <= Lrows
LChangedValue = "A" & CStr(LLoop)

If Not Intersect(Range(LChangedValue), Target) Is Nothing Then
If Len(Range(LChangedValue).Value) > 0 Then

'Test each value for uniqueness
LTestLoop = 2
While LTestLoop <= Lrows
If LLoop <> LTestLoop Then
LTestValue = "A" & CStr(LTestLoop)
'Value has been duplicated in another cell
If Range(LChangedValue).Value = Range(LTestValue).Value Then
'Set the background color to red
Range(LChangedValue).Interior.ColorIndex = 3
MsgBox Range(LChangedValue).Value & " already exists in cell A" & LTestLoop
Exit Sub
Else
Range(LChangedValue).Interior.ColorIndex = xlNone
End If

End If

LTestLoop = LTestLoop + 1
Wend

End If
End If

LLoop = LLoop + 1
Wend

End Sub

maskos
Честно говоря, код еще тот... Поэтому не проверял ни оригинал, ни модификацию.
Именно для столбца "B". Где-то [more=так:]

Код: Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Select Case Target.Column
Case 1, 2
Dim LLoop As Integer
Dim LTestLoop As Integer

Dim Lrows As Integer
Dim LRange As String
Dim LChangedValue As String
Dim LTestValue As String

'Test first 200 rows in spreadsheet for uniqueness
Lrows = 200
LLoop = 2

Dim sColChr$(1 To 2)
sColChr(1) = "A": sColChr(1) = "B"

'Check first 200 rows in spreadsheet
While LLoop <= Lrows
LChangedValue = sColChr(Target.Column) & CStr(LLoop)

If Not Intersect(Range(LChangedValue), Target) Is Nothing Then
If Len(Range(LChangedValue).Value) > 0 Then

'Test each value for uniqueness
LTestLoop = 2
While LTestLoop <= Lrows
If LLoop <> LTestLoop Then
LTestValue = sColChr(Target.Column) & CStr(LTestLoop)
'Value has been duplicated in another cell
If Range(LChangedValue).Value = Range(LTestValue).Value Then
'Set the background color to red
Range(LChangedValue).Interior.ColorIndex = 3
MsgBox Range(LChangedValue).Value & " already exists in cell " & sColChr(Target.Column) & LTestLoop
Exit Sub
Else
Range(LChangedValue).Interior.ColorIndex = xlNone
End If

End If

LTestLoop = LTestLoop + 1
Wend

End If
End If

LLoop = LLoop + 1
Wend
Case Else
' do nothing
End Select

End Sub

grbdv
первым делом спасибо за ответ


Цитата:

Честно говоря, код еще тот..

имеется ввиду криво написан?
если да, то для меня это не важно (т.к. все-равно не совсем понимаю что там написано ), главное что работает


Цитата:

Поэтому не проверял ни оригинал, ни модификацию.

оригинал работает только на столбец А.
модификация - значения в столбце А не проверяет, а при вводе любого значения в столбец В вылетает ошибка "runtime error '1004' : method 'range' of object'_worksheet' failed", а при нажатии кнопки debug подсвечивает желтым цветом строчку - If Not Intersect(Range(LChangedValue), Target) Is Nothing Then

я, конечно, попытаюсь сравнить их и попытаться склеить в нечто единое по вашей наводке, но не уверен что получится, я уже пытался похожим образом поступать..

maskos
Придется видно проверять... блин :((
Идея модификации была такова:
Если колонка объекта Target.Column равна 1 или 2, то тогда выполняем оригинальный код. Разница только в том, где использовались "A" - подставляется соответствующее значение из массива sColChr(Target.Column), заполненного загодя.

Епт... Увидел ошибку. Давал же зарок себе - не копипастить, руками писать... Значения поменял, а индексы - нет :(
Найди строку:
sColChr(1) = "A": sColChr(1) = "B"
замени на
sColChr(1) = "A": sColChr(2) = "B"

AndVGri, БЛАГОДАРЮ, СРАБОТАЛО.

grbdv

Цитата:

Придется видно проверять... блин (

Все заработало

большое спасибо за то что помогли и потратили свое время, выручили

Добрый день!

Не могли бы вы помочь сделать следующий макрос:
Дано:
В столбик по строкам введена информация:
Название
Телефон
Факс
Емейл
Сайт
Присутствуют пустые строки
Нужно:
Распределить (транспонировать) имеющуюся информацию в столбцы:
Название Телефон Факс и т.д.
Действие необходимо сделать из столбца А в остальные столбцы на этом же листе.
При этом нужно прописать следующее:
1. Если ячейка содержит кавычки и текст в ней написан большими буквами (Caps Lock), то информация помещается в столбец В
2. Если ячейка содержит текст "Факс", то информация из нее помещается в столбец F и т.д.
3. Далее, если ячейка содержит кавычки и текст в ней написан большими буквами (Caps Lock), то информация помещается в столбец В на 1 строку ниже.
4. Если ячейка пустая - то ничего с ней не делаем.

Короче, меня есть список контактов Икселе, и написали его просто последовательно в столбик, в каждой ячейке вышеуказанная информация, сейчас мне надо этот список конвертировать в CRM, для чего необходимо сделать таблицу

Заранее очень премного благодарен!

leonrtt

Цитата:

Не могли бы вы помочь сделать следующий макрос...

Добрый. А что не получается то?
Шапка читам?


Я бы привел число строк в записи к единому. Транспонировал бы формулами. Собрал потом в единый массив данных. Что можно - формулами же распарсил. Потом работал бы ужЕ, как с нормальной БД.

Символьная строка представляет собой шестна-дцатеричную запись числа. Перевести это число в двоич-ную систему счисления.
Подскажите плиз написать, завтра сдать нужно. Заранее спасибо

NiNo52RUS
Функция для преобразования одного символа в 16-ном представлении в двоичное

Код:
Option Compare Text
Public Function HexToBinary(ByVal hex As String) As String
Select Case hex
Case "0": HexToBinary = "0000"
Case "1": HexToBinary = "0001"
Case "2": HexToBinary = "0010"
Case "3": HexToBinary = "0011"
Case "4": HexToBinary = "0100"
Case "5": HexToBinary = "0101"
Case "6": HexToBinary = "0110"
Case "7": HexToBinary = "0111"
Case "8": HexToBinary = "1000"
Case "9": HexToBinary = "1001"
Case "A": HexToBinary = "1010"
Case "B": HexToBinary = "1011"
Case "C": HexToBinary = "1100"
Case "D": HexToBinary = "1101"
Case "E": HexToBinary = "1110"
Case "F": HexToBinary = "1111"
Case Else: HexToBinary = ""
End Select
End Function

Есть некая таблица А1-Е2 в которой цифрам я задаю определённый цвет ячейки.
http://rghost.ru/30032371
Как сделать так, что-бы где только не встречались на листе цифры, надо что-бы их цвет заливки соответствовал заданному мной цвету упомянутой (А1:Е2) таблицы.
Т.е. задал я единице сегодня красный -значит все единицы на листе должны быть красной заливки.
Задал единице завтра скажем зелёный цвет -все зелёные и т.д.
И так же с другими цифрами.
Может ли кто нибудь помочь это сделать?

Niiks
[more]

Код:
Option Explicit

Public Sub Colorize()
On Error Resume Next
Dim baseRange As Excel.Range
Dim nextCell As Excel.Range, sKey As String
Dim pDict As Object, needCell As Excel.Range
Dim colorRange As Excel.Range
Set colorRange = ActiveSheet.Range("A1:E2")
Set pDict = CreateObject("Scripting.Dictionary")
For Each nextCell In colorRange
If (Not IsEmpty(nextCell.Value)) And IsNumeric(nextCell.Value) Then
sKey = CStr(CLng(nextCell.Value))
If Not pDict.Exists(sKey) Then pDict.Add sKey, nextCell
End If
Next nextCell
Set needCell = Nothing: Set baseRange = Nothing
Set baseRange = ActiveSheet.UsedRange.SpecialCells(XlCellType.xlCellTypeConstants, XlSpecialCellsValue.xlNumbers)
Set needCell = ActiveSheet.UsedRange.SpecialCells(XlCellType.xlCellTypeFormulas, XlSpecialCellsValue.xlNumbers)
If (Not baseRange Is Nothing) And (Not needCell Is Nothing) Then
Set baseRange = Application.Union(baseRange, needCell)
ElseIf Not needCell Is Nothing Then
Set baseRange = needCell
End If
If baseRange Is Nothing Then Exit Sub
If pDict.Count = 0 Then Exit Sub
For Each nextCell In baseRange
If (Not IsEmpty(nextCell.Value)) And IsNumeric(nextCell.Value) Then
sKey = CStr(CLng(nextCell.Value))
If Application.Intersect(nextCell, colorRange) Is Nothing Then
If pDict.Exists(sKey) Then
Set needCell = pDict.Item(sKey)
nextCell.Interior.Color = needCell.Interior.Color
End If
End If
End If
Next nextCell
End Sub

AndVGri, спасибо

Цитата:

Niiks
Подробнее... [

Извиняюсь за ламерский вопрос, но как это всё заставить работать в Excel 2003

Niiks
[more=Мм-да]
1. Открываете Excel с книгой с листом где таблица код-цвет заливки. Нажимаете Alt+F11 - попадаете в редактор VBA
2. В меню Insert выбираете Module и вставляете код
3. На листе где таблица код-цвет заливки на в меню СЕРВИС/МАКРОС/МАКРОСЫ.. в диалоговом окне выбираете Colorize и жмёте кнопку ВЫПОЛНИТЬ
4. Сохраняете книгу. При следующем запуске/необходимости с 3 пункта. Можете привязать макрос к пользовательской кнопке
[/more]

Пытаюсь перекроить свой скрипт с VBscript на VBA excel.
Проблема. Не могу заставить работать событие объекта Winsock1 по открытию порта (как собственно и другие события).
Порт открывается, но события не срабатывают.

Код: Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'----------------------------------------
Sub Init()
Set Winsock1 = CreateObject("MSWinsock.Winsock")
Winsock1.RemoteHost = "192.168.1.1"
Winsock1.RemotePort = 9013
Winsock1.Connect
Do While (Winsock1.State <> sckConnected)
Debug.Print Winsock1.State: DoEvents
Sleep 200
Loop
Debug.Print Winsock1.State
Winsock1.Close
Debug.Print Winsock1.State
End Sub
'-----------------------------------------
Private Sub Winsock1_Connect()
MsgBox "Port 9013 Connect"
End Sub

dandyd
Ну как минимум объявите в классе
Dim WithEvents Winsock1 As TypeName
Где TypeName название класса, который находится в библиотеке, подключенной через Tools/Reference
(Правда MSWinsock.Winsock у себя не нашёл, чтобы подсказать что-либо подробнее)

Цитата:

Ну как минимум объявите в классе
Dim WithEvents Winsock1 As TypeName
Где TypeName название класса, который находится в библиотеке, подключенной через Tools/Reference
(Правда MSWinsock.Winsock у себя не нашёл, чтобы подсказать что-либо подробнее)

Что-то я запутался.
В Tools/Reference эта вещь называется Microsoft Winsock Control 6.0 (SP6).
При ее включении в Object Browser по F2 появляется библиотека MSWinsockLib с классом

Class Winsock
Member of MSWinsockLib
Microsoft Winsock Control

Там есть все методы и события.

Создал модуль класса с именем Winsock1
Вставил туда
Dim WithEvents Winsock1 As MSWinsockLib.Winsock

Остальной мой код (см. письмо выше) остался в обычном модуле.
Так событие все раввно не работает
Private Sub Winsock1_Connect()
MsgBox "Port 9013 Connect"
End Sub

Что-то не то делаю.

Почитал про модули классов - вроде как они предназначены для создания своих объектов, а я пользуюсь уже существующим.

Цитата:

Мм-да

Цитата:

1. Открываете Excel с книгой с листом где таблица код-цвет заливки. Нажимаете Alt+F11 - попадаете в редактор VBA
2. В меню Insert выбираете Module и вставляете код
3. На листе где таблица код-цвет заливки на в меню СЕРВИС/МАКРОС/МАКРОСЫ.. в диалоговом окне выбираете Colorize и жмёте кнопку ВЫПОЛНИТЬ
4. Сохраняете книгу. При следующем запуске/необходимости с 3 пункта. Можете привязать макрос к пользовательской кнопке

AndVGri, всё сделал в точности, но...
Не работает

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

Код: Private Sub Worksheet_Change(ByVal Target As Range)
Dim objRange As Object, x As Object
Set objRange = UsedRange.Columns(Target.Column)
objRange.Interior.ColorIndex = 0
On Error GoTo L1
With New Collection
For Each x In objRange.Cells
If x <> "" Then .Add x.Value, CStr(x.Value)
Next
End With
L1: If Err > 0 Then If x.Interior.ColorIndex = xlNone Then x.Interior.ColorIndex = 6: Resume Next
With Target.Font
.Name = "Tahoma"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
End Sub

Нужно реализовать такую штуку. В коде макроса прописать команды для реализации следующего

1. В любой ячейке вставляется первое число предыдущего текущему месяца в формате dd.mm.yy
2. Вычисляется сколько дней в этом месяце было
3. Диапазон растягивается вправо на число дней месяца

Застрял на первом пункте. Ткните носом пожалуйста как это можно реализовать?

Niiks
Не работает что? Поконкретнее: не закрашивает, не выполняется, выдаёт ошибку? По Вашему примеру всё работало (убирал заливку со строк начиная с 3, ниже таблицы A1:E2)

lorents

Цитата:

If x.Interior.ColorIndex = xlNone

должно быть

Код:
If x.Interior.ColorIndex = XlColorIndex.xlColorIndexNone

AndVGri
Спасибо за ответ. А первое число как на лист получить?