» Excel VBA (часть 3)

Большое спасибо.

TXP, см. личку - поправки к коду

grbdv
обратил внимание что как-то много повторов получается.
К примеру на 100 сгенеренных строк выходит 3-4 одинаковые строки (т.е. с одинаковым набором слов). При том что в исходных данных порядка 80 уникальных слов и словосочетаний.

Есть возможность, скажем так, усилить рандомность?

Спасибо.

Сие до кучи доже оптимизируйте, так как сам в программировании не разбираюсь в данном коде нужно убрать переход на ячейку "АН3", т.е. если я работая с данными в какой либо ячейке, после активации кода и оставался бы в данной ячейке (надеюсь понятно объяснил)

Код: Private Sub TBut1_Change()
Range("AH3").Select
If TBut1.Value Then
TBut1.Caption = "с НДС"
ActiveCell.FormulaR1C1 = "2"
Else
TBut1.Caption = "без НДС"
ActiveCell.FormulaR1C1 = "1"
End If

End Sub

Fader

Цитата:

Есть возможность, скажем так, усилить рандомность?

М-да... К сожалению прогноз AndVGri оказался в пару раз оптимистиченей реальности :((
Пусть про генератор псевдиков он сделает резюие, я же писал выше - я плаваю в этой теме :(
А я подумаю над проверкой на уникальность, но это очень утяжелит код :(

Добавлено:
Без проверки на уникальность можно и, пожалуй, нужно сделать [more=следующее:]
1. В область деклараций над Sub sb_KeyWords() вставить:

Код:
Public Declare Function GetTickCount& Lib "Kernel32" ()
Public Declare Sub Sleep Lib "Kernel32" (ByVal lMSec&)

grbdv


Цитата:

Это, до кучи, требование или приказ?

Скорее просьба, в эпистолярном жанре не силен.

Спасибо за код.

grbdv
позвольте несколько уточнений:

Область деклараций: нужен также код под x64
'Timer + n' встречается 3 раза. у вас же описаны апдейты словно их 2

Fader

Цитата:

Область деклараций: нужен также код под x64

Не сталкивался ни разу с х64. Ищи практика, как там будут они декларироваться.


Цитата:

'Timer + n' встречается 3 раза. у вас же описаны апдейты словно их 2

Блин... Я не мог даже предположить, что здесь будет спотыкач...
Вторым пунктом написано "везде". В третьем говорится про два. Не странно ли? Можно было догадаться, что не случайно?

Для нас критичны именно два последних. Первый раз нам пофиг вообще от чего плясать - хоть от числа Пи, и в этот момент таймер и так уникальный и он не используется в цикле. Что о нем говорить?

Randomize:
1 - Без задержки - Устанавливаем случайное кол-во строк в рез. файле - используется единственный раз
2 - 50 - Устанавливаем случайное кол-во фраз в строке - используется для каждой строки iW_Lines(0) раз
3 - 20 - Выбираем случайную фразу из имеющихся - используется для каждой фразы в строке iW_Words(0) раз
50 и 20 - это верхние пределы для псевдиков, рандомно генерируемых на предыдущем опорном (пофиг на каком), определяющих величину задержек в мсек, на которые мы позволяем сместиться таймеру, новое значение которого будет использовано в качестве опорного для соответствующего генератора псевдиков. Последняя меньше - т.к. самый востребованный цикл.

М-да... Ведь явно или там, или там ошибка-опечатка-недосказанность. А прочитать и сделать вместо "два" - "везде"? Или наоборот? Поиграть с 20 и 50 - никак не судьба?

Результатов, значит, вообще никаких нет?

grbdv
Оценённая вероятность касалась того, что две строки по шесть слов каждая будут (при длине словаря 30 слов) одинаковыми.
При той же длине словаря для двух строк по три слова вероятность их совпадения p=0.157.
При длине словаря 80 слов - p=0.0274
По данным Fader 4 / 100. p1 = 0.04. p1 - p = 0.0126
Вывод "плохой" генератор случайных чисел в VBA конечно вносит свою лепту, но основная проблема в алгоритме. Даже при идеальном генераторе нет возможности исключить появление одного и того же индекса выборки из массива словаря подряд для одной строки (пусть и вероятность мала). Следующее. Задание говорит об генерации сочетаний, то есть 123, 213, 321 и т. д. - одинаковые строки и в результате должна присутствовать только одна из этих форм.

Кому попадалось, как снять защиту с VBA проекта в Excel 2007-2010 в формате расширеня xlam?

AndVGri

Цитата:

Оценённая вероятность .... основная проблема в алгоритме ... одна из этих форм.

Эту мудрую фразу ни запустить, ни скомпилировать. Постеснялся бы разводить теорию и указывать на ущербность алгоритма не приведя ни строчки кода. Или только за фиатки работаешь? Короче, код в студию.

grbdv
А зачем мне приводить твой код?

Цитата:

Короче, код в студию

Код:
k = Int((iQty - 1 + 1) * Rnd + 1)
sTgt = sTgt & sDlm & Trim(sSrc(k))

Цитата:

Я могу помочь

Так помогай. А ты пока только флеймишь вдохновленно на тему разницы между "случайный" и "уникальный". Задача-то не моя, а Фадера. Куда он твои рассуждения вклеит? Есть конкретные предложения?

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

grbdv
А Flader её делает? Делаете Вы, вот Вам и помогаю, объясняю недостатки реализации. За советом пока Вы не обращались. Так что. Предлагаю изменить алгоритм на выборку случайных карт из колоды.

AndVGri

Цитата:

А Flader её делает?

У него спроси.
Завязывай троллить, пустозвон. Кнопку нажать недолго.
Все остальные вопросы - только по делу. Без альтернативного кода со своими "соображениями" даже близко не подходи. Теоретик...

Fader
Последний [more=вариант:]

Код:
Sub sb_KeyWords_2()
Dim fso As FileSystemObject
Dim strR As TextStream, strW As TextStream
Dim lIdx_Phr&(), lIdx_Lin&()
Dim i%, j%, k%, m%, n%, iQty%, iW_Lin%(3), iW_Phr%(3), iFormat%
Dim bU_Lin As Boolean, bU_Phr As Boolean
Dim sPath$, sFileR$, sFileW$, sDlm$, sSfx$, sExt$, sSrc$(), sTgt$

' USER DATA SETUP
iW_Lin(1) = 290: iW_Lin(2) = 300 ' Low & Upper bounds of lines in target file
iW_Phr(1) = 3: iW_Phr(2) = 6 ' Low & Upper bounds of elements in line

sPath = "C:\Path1\Path2\Path3" ' type real path here w/o ending slash

sFileR = "TextPhrases" ' Name of sourse file
sSfx = "Rnd" ' Suffix of target file
sExt = "txt" ' A same extension for both of files
sDlm = "," ' Delimiter

iFormat = TristateUseDefault ' -2 - Opens the file using the system default
' iFormat = TristateMixed ' -2 - Opens the file using the system default
' iFormat = TristateTrue ' -1 - Opens the file as Unicode
' iFormat = TristateFalse ' 0 - Opens the file as ASCII

' PROCEDURE
sFileW = sFileR & "_" & sSfx
sFileR = sPath & "\" & sFileR & "." & sExt
sFileW = sPath & "\" & sFileW & "." & sExt

Set fso = CreateObject("Scripting.FileSystemObject")

With fso
Set strR = .OpenTextFile(sFileR, ForReading, , iFormat)
With strR
Do While Not .AtEndOfStream
iQty = iQty + 1
ReDim Preserve sSrc(1 To iQty)
sSrc(iQty) = .ReadLine
Loop
End With

Set strW = .OpenTextFile(sFileW, ForWriting, True, iFormat)

Randomize (GetTickCount) ' Set lines per file qty
iW_Lin(0) = Int((iW_Lin(2) - iW_Lin(1) + 1) * Rnd + iW_Lin(1))

ReDim lIdx_Lin(1 To 1)
For i = 1 To iW_Lin(0)
Sleep (Int(10 * Rnd + 1))
Randomize (GetTickCount) ' Set phrases qty
iW_Phr(0) = Int((iW_Phr(2) - iW_Phr(1) + 1) * Rnd + iW_Phr(1))

bU_Lin = True
ReDim Preserve lIdx_Lin(1 To i)
Do
sTgt = ""
ReDim lIdx_Phr(1 To 1)

Sleep (Int(10 * Rnd + 1))
Randomize (GetTickCount) ' Set phrases per line qty
For j = 1 To iW_Phr(0)
bU_Phr = True
ReDim Preserve lIdx_Phr(1 To j)
Do
k = Int((iQty - 1 + 1) * Rnd + 1)
For m = 1 To (j - 1)
bU_Phr = (k <> lIdx_Phr(m))
If Not bU_Phr Then Exit For
Next
Loop Until bU_Phr
lIdx_Phr(j) = k
lIdx_Lin(i) = lIdx_Lin(i) + k * (10 ^ j)
sTgt = sTgt & sDlm & Trim(sSrc(k))
Next
sTgt = Right(sTgt, Len(sTgt) - 1)

For n = 1 To (i - 1)
bU_Lin = (lIdx_Lin(n) <> lIdx_Lin(i))
If Not bU_Lin Then Exit For
Next

Loop Until bU_Lin
strW.WriteLine (sTgt)
Next
End With
End Sub

grbdv

Fader
Читай тему.

grbdv
На этом спасибо, результат устроил. Развернул на продакшене уже.

Хочу заметить что нечасто встретишь человека который существенно помог бы за просто так.
Респект и уважуха вобщем!

Fader
Слава Богу.

Думаю, что теперь, без опасений за уникальность, можно смело в принудительных задержках заменить оба вхождения:
Sleep (Int(10 * Rnd + 1))
на просто:
Sleep (2)
Быстродействие увеличится и будет определяться уже лишь вероятностью возникновения дублей.

Redduck9
Проще, наверное, сбросить таблицу (xls) Excel в csv файл в ту же папку, где лежит требуемый csv файл (csv) и уже запросом "Select csv.* From csv Left Join xls Where xls.id Is Null"
Можно конечно и извратиться, собрать из таблицы Excel все занчения id в строку
vIds = "(num1,num2,num3)". И получить требуемое запросом "Select csv.* From csv Where csv.id Not In " & vIds". Ну и наоборот теми же способами.
Добавлено
Можно в конце-концов создать в базе данных Access таблицы-связи с Excel таблицей и csv файлом, а далее стандартно

Возможно ли, чтобы при открытии документа осуществлялся поиск макросов/форм в определенной папке и их последующее добавление в этот документ?

Подскажите пожалуйста, у меня есть массив Dlt в который занесены номера листов с определённм признаком. и теперь мне нужно удалить РАЗОМ листы с этими номерами( то есть сделать цикл и удалить листы по очереди не пойдёт, тк номера листов будут сдвигаться ).
Мой не работающий код выглядит так:


Код: Sub test1()

Dim dlt() As String
ReDim dlt(500)
v = 1
For x = 1 To Sheets.Count
Sheets(x).Select
If Range("B6") <> "" Then
dlt(v) = x
v = v + 1
End If
Next x
ReDim Preserve dlt(v - 1)
Worksheets(dlt).Delete
end sub

В Microsoft Excel по умолчанию примечание создается размером 2.09 на 3.81. Мне необходимо, чтоб создаваемое мной примечание имело размер примерно 11 на 8 (при ручном изменении получается 11.01 на 7.99, так тоже нормально).
Кто может, создайте пожалуйста рабочий макрос на ctrl+q создание пустого примечания размером 11 на 8, буду очень признателен Пробовал сам, но что то у меня не получается, выдает постоянно ошибку (может excel у меня что тупит или руки кривые)

Zloy_Gelud
Установить
Доверять доступ к объектной модели проектов VBA

Код:
ThisWorkbook.VBProject.VBComponents.Import "d:\path\module1.bas"

AndVGri
Но я именно так не могу сделать. Тк, если ты обратишь внимание на мой код, то увидишь, что у меня все номера нужных листов сохранены в массиве dlt. И проблема в том, что Worksheets не хочет переваривать этот dlt. Может есть какой-то способ перевести этот dlt к виду array(1,2,3...)... Или у меня кака-то обшибка в коде...

sergei99959
Ниже [more=код:]

Код:
Sub sb_CommentsFormat()
Dim rng As Range
Dim sMsg$

Set rng = Selection
With rng
Select Case .Cells.Count
Case 1
Select Case .Comment Is Nothing
Case True
sMsg = "No comment in cell"
Case False
With .Comment.Shape
.ScaleWidth 1.36, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.95, msoFalse, msoScaleFromTopLeft
End With
End Select
Case Else
sMsg = "Multiple selection!"
End Select
End With
If Len(sMsg) > 0 Then MsgBox sMsg
End Sub

Чёт нифига не получается у меня опять No comment in cell вылазит с этим кодом

Jizo
Странно

Код:
Public Sub test()
Dim vList(1 To 3) As Long
vList(1) = 1: vList(2) = 3: vList(3) = 5
Application.DisplayAlerts = False
Worksheets(vList).Delete
Application.DisplayAlerts = True
End Sub

Цитата:

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 = 11: pComment.Shape.Height = 8
End Sub

С этим получается вставлять примечания, только размер у него получается 0,29 см х 0,4 см, а не 11х9

Начинаю менять размер, на 11,01х7,99 выдает ошибку из-за запятой. Ставлю 11.01х7.99 - всё равно при выполнении получается примечание размером 0,29 см х 0,4 см

Как нужный размер то поставить???

sergei99959

Цитата:

Чёт нифига не получается у меня опять No comment in cell вылазит с этим кодом

Только что перепроверил - все работает, размер примечания меняется.
Предполагается, что будет выделена одна ячейка, имеющая примечание.
Если вылазит "No comment in cell" - значит в данной ячейке нет примечания...
Есди будет выделено больше одной ячейки, то вылезет "Multiple selection!"

Добавлено:

Цитата:

С этим получается вставлять примечания,

Хм-м... Ничего оно не вставляет. Только меняет размер имеющегося.

Цитата:

Как нужный размер то поставить???

Щаз, пересчитаю. Я-то цифры от балды ставил.