» Excel VBA (часть 3)

levn
Цитата:

Только не получается прикрутить еще кнопку Cancel,

Тогда вместо

Код:
vbYesNo Or vbInformation Or vbDefaultButton1

Существует ли способ объединить несколько таблиц в одну, каждую как вкладка, не делая этого руками? Какой макрос работает наилучшим образом в Офисе 2010 для однолистовых файлов с двумя пустыми вкладками (которые по-умолчанию создаются), которые желательно чтобы игнорировались при объединении?

Цитата:

объединить несколько таблиц в одну

Наверное имеется ввиду файлы, а не таблицы? Примерный вариант кода (пишу как обычно без отладчика, но идея будет понятна).

Код: Sub My
Dim WB As Workbook, WS As worksheet, FName As String
FName = Dir(ThisWorkbook.Path & "\*.xls*")
While Not FName = ""
If Not FName = Thisworkbook.Name Then
Set WB = Workbooks.Open(Thisworkbook.Path & "\" & FName) ' Сюда еще можно вставить параметр "открывать только для чтения"
For Each WS In WB.Worksheets
If Not WS.Cells.SpecialCells(xlcelltypelastrow).row=1 Then
WS.Copy after:=Thisworkbook.ActiveSheet
End If
Next WS
WB.Close False
End If
FName = Dir()
WEnd

Есть событие которое нужно мониторить каждые 15 минут до окончания матча.

например предстоящее событие
https://livescorepro.softnetsport.com/site/live/soccer/4768742?lang=en&size=748x570&client_id=67&template=default1_750x570&t=eb9d08f59c02745f547c2814f78b9d2f


принимаю данные с помощью макроса


Код: Sub Macro1()

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;https://livescorepro.softnetsport.com/site/live/soccer/4768742?lang=en&size=748x570&client_id=67&template=default1_750x570&t=eb9d08f59c02745f547c2814f78b9d2f" _
, Destination:=Range("$A$1"))
.Name = _
"4768742?lang=en&size=748x570&client_id=67&template=default1_750x570&t=eb9d08f59c02745f547c2814f78b9d2f"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
'.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
Application.OnTime Now + TimeValue("00:15:40"), "Macro1"
End With
End Sub

Друзья, можете помочь написать код
идея такая: вот есть эксель с результатами корреляции
http://rghost.ru/56625498
нас интересуют только красные. это значит, что переменные достоверно коррелируют между собой
Нужен макрос которые все это хозяйство переводит в блокнот, но только те, что достоверно коррелируют т.е. красные

блокнот должен иметь такую структуру
*Vertices 4 (это сколько переменных коррелируют, вернее те корреляции между которых достоверны)
1 "Бегство-избегание"
2 "непринятие других"
3 "Эмоциональный дискомфорт"
4 "Принятие ответственности"

*Edges тут номер переменной которая корр с другим номером переменном т.е. корреляция переменной 1 с переменной 2, а через пробел коэф.корреляции 0,25
1 2 0.250
1 3 0.400
3 4 0.300

т.е. макрос должен найти все красные корреляции
создать блокнот и таким образом прописать. если число "красный переменных" больше 4, то
*Vertices 100500


а иджес
все это комбинации корреляций в данном случае всего 3 комбинации корреляций 1 и 2; 1 и 3; и 3 и 4.

Просто массивы корреляций в психологических исследованиях бывают большие и всех их выписывать - это убийство

Fsp050
Не совсем ясно, в каком виде находятся Ваши массивы корреляций, но Ваш пример разбирает вот такой макрос, возможно сможете подстроить его под Ваши нужды:


Код:

Sub test()
Dim i&, l&, x&, y&, z&, s$, s1$, s2$, a(1 To 12, 1 To 3)
Dim key, item
Dim oDict: Set oDict = CreateObject("Scripting.Dictionary"): oDict.CompareMode = vbBinaryCompare

x = 1: y = 1: z = 1
For i = 2 To 5
For l = 2 To 4
If Cells(i, l).Font.ColorIndex = 3 Then
s1 = Cells(i, 1).Value
If oDict.Exists(s1) = True Then
Else
oDict.item(s1) = x
x = x + 1
End If
s2 = Cells(1, l).Value
If oDict.Exists(s2) = True Then
Else
oDict.item(s2) = x
x = x + 1
End If

a(y, 1) = s1
a(y, 2) = s2
a(y, 3) = Cells(i, l).Value
y = y + 1
End If
Next l
Next i

key = oDict.Keys
item = oDict.Items
If oDict.Count > 4 Then s = "*Vertices 100500" Else s = "*Vertices " & oDict.Count
Open "D:\\file.txt" For Append As #1
Print #1, s
For i = 0 To UBound(key)
Print #1, (item(i) & " " & key(i))
Next i

Print #1, ""
Print #1, "*Edges"
For i = 1 To 12
Print #1, (oDict.item(a(i, 1)) & " " & oDict.item(a(i, 2)) & " " & a(i, 3))
Next i
Close #1
End Sub

andrewkard1980
премного Вам благодарен.
Если, что будет не получаться отпишусь.

andrewkard1980
ваш макрос прекрасно работает.
но такой вопрос
мне чисто для аналогии
как он будет выглядеть для файла, где больше корреляций
http://rghost.ru/56741820
просто так сравнивая , я сам пойму какие части макроса надо редактировать.

Fsp050
Чуть исправил, ед. на что надо обращать внимание, это на размерность массива для вывода результатов (к-во красных ячеек), пока поставил на 100 шт.

Код: Sub test()
Dim i&, l&, x&, y&, z&, s$, s1$, s2$, a(1 To 100, 1 To 3) 'до 100 красных ячеек
Dim key, item
Dim oDict: Set oDict = CreateObject("Scripting.Dictionary"): oDict.CompareMode = vbBinaryCompare

x = 1: y = 1: z = 1
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For l = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
If Cells(i, l).Font.ColorIndex = 3 Then
s1 = Cells(i, 1).Value
If oDict.Exists(s1) = True Then
Else
oDict.item(s1) = x
x = x + 1
End If
s2 = Cells(1, l).Value
If oDict.Exists(s2) = True Then
Else
oDict.item(s2) = x
x = x + 1
End If

a(y, 1) = s1
a(y, 2) = s2
a(y, 3) = Cells(i, l).Value
y = y + 1
End If
Next l
Next i

key = oDict.Keys
item = oDict.Items
If oDict.Count > 4 Then s = "*Vertices 100500" Else s = "*Vertices " & oDict.Count
Open "D:\\file.txt" For Append As #1
Print #1, s
For i = 0 To UBound(key)
Print #1, (item(i) & " " & key(i))
Next i

Print #1, ""
Print #1, "*Edges"
For i = 1 To 100 'до 100 красных ячеек
Print #1, (oDict.item(a(i, 1)) & " " & oDict.item(a(i, 2)) & " " & a(i, 3))
Next i
Close #1
End Sub

ага понял

доброго времени суток. помогите. сделать макрос в excel
нужно выводить картинку на активный лист excel в определенную ячейку, при открытии excel, т.к. картинку нужно выводить не в каждый открывающийся excel файл, а только в определенные, то наверно это можно реализовать проверкой условия наличия в определенной ячейке определенного "кода"(слова, набора символов).
что-то типа этого :
открывается excel
запускается макрос
макрос проверяет есть ли в ячейке А1 слово "картинка"
если есть, вставляет в ячейку B3 файл С:\Картинка.jpg
конец

excel90
В модуль каждой необходимой книги нужно поместить:

Код:
Private Sub Workbook_Open()
Set rRng = Cells(3, 2)
Set pPic = rRng.Parent.Pictures.Insert("D:\Картинка.jpg")

With pPic
.Top = rRng.Top + 2
.Left = rRng.Left + 2
.Height = rRng.Height + 20
.Width = rRng.Width - 2
End With
End Sub

Спасибо за помощь! Сейчас проверю

excel90
Ок






Добавлено:
Еще можно поместить макрос в модуль Эта книга Персональной книги макросов и проверять имя книги по маске:

Код:
Private WithEvents App As Application
Private Sub Workbook_Open()
Set App = Application
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
If Wb.Name Like "*qrq*" Then
Set rRng = Cells(3, 2)
Set pPic = rRng.Parent.Pictures.Insert("D:\Картинка.jpg")

With pPic
.Top = rRng.Top + 2
.Left = rRng.Left + 2
.Height = rRng.Height + 20
.Width = rRng.Width - 2
End With
End If
End Sub

Добрый вечер, уважаемые форумчане!
Снова надеюсь на Вашу помощь. Стал довольно часто сталкиваться с тем, что необходимо сравнить 2 диапазона таблиц из разных книг. Всего, на пример, 16 наименований товаров (пример в файле). Я должен просмотреть оба списка книг, выявить, каких наименований нет в этих двух списках, а также, какие наименования встречаются в обоих списках. Всего бы ничего, но наименований бывают и 300, и 400, и больше... Данные для сравнения могут быть как текстовые, так и числовые. Вручную очень долго и тяжело просматривать. Может, есть какое-то решение по данному вопросу?
Буду очень признателен за любую помощь!
http://rghost.ru/56907540

Leojse
есть программа Excel Compare

XPerformer
Спасибо, буду думать над покупкой.

еще одна Compare Spreadsheets for Excel

Недавно уважаемый andrewkard1980 подсказал, как проверять [more=имя книги по маске ] Еще можно поместить макрос в модуль Эта книга Персональной книги макросов и проверять имя книги по маске:

Код:

Private WithEvents App As Application
Private Sub Workbook_Open()
Set App = Application
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
If Wb.Name Like "*qrq*" Then
Set rRng = Cells(3, 2)
Set pPic = rRng.Parent.Pictures.Insert("D:\Картинка.jpg")

With pPic
.Top = rRng.Top + 2
.Left = rRng.Left + 2
.Height = rRng.Height + 20
.Width = rRng.Width - 2
End With
End If
End Sub


Код не мой...Ссылка: http://www.excel-vba.ru/chto-umeet-excel/kak-otsledit-sobytienaprimer-vydelenie-yacheek-v-lyuboj-knige/
[/more]

Может ли кто подсказать, как проверить по маскам наличие PDF и DOC файлов (если это вообще возможно)?

dzefas
Можно, например:

Код: Sub test()
Dim oFS As Object, oFl As Object
Dim sFtFd$
sFtFd = ActiveWorkbook.Path & "\"
Set oFS = CreateObject("scripting.filesystemobject")
Set oFS = oFS.getfolder(sFtFd)
For Each oFl In oFS.Files
If oFl.Name Like "*.pdf" Then MsgBox oFl.Name
Next
End Sub

andrewkard1980
Спасибо, очень помогло!

dzefas
Еще пример. без FSO и Like:

Код: Sub test2()
Dim sFtFd As String, f As String
sFtFd = ActiveWorkbook.Path & "\"
f = Dir(sFtFd & "*.pdf")
Do While f <> ""
MsgBox f
f = Dir
Loop
End Sub

SAS888
Спасибо, действительно, интересное и более простое решение.
К сожалению, такое решение не всегда возможно: в моем случае больше помог совет andrewkard1980, т.к. если в пути есть буквы типа "&#269;", "&#353;","&#279;", то нужный файл не открывался (не находился).

Я не знаю, как напечатать буквы, чтобы отображались они, а не "&#269;". Что-то наподобие "ё" на латинице.

Добрый день! подскажите, пожалуйста, есть готовый макрос для пакетной замены русского текста в большого количества файлов EXCEL в папке?

andrewkard1980
Подскажите, в чем м.б. дело. вот файл
http://rghost.ru/56961291
,тут тот много корреляций красных. 49х49
но почему то, когда запускаю макрос пишет ошибку рантайм еррор 9
Можете, пож-та, посмотреть что ему не нравится.

Lillu
Вы имеете ввиду переименование (транслитерацию)?

Добавлено:
Fsp050
Увеличьте размерность массива до 1000 вместо 100:
Dim i&, l&, x&, y&, z&, s$, s1$, s2$, a(1 To 1000, 1 To 3)

и тут:
Print #1, "*Edges"
For i = 1 To 1000

andrewkard1980
спасибо Вам. помогло

[more] Здравствуйте, нужно написать макрос чтобы он по условию удалял столбцы.

есть макрос который удаляет строки по условию, которое он ищет в определенном столбце, вот он.
Sub Del_SubStr()
Dim sSubStr As String 'искомое слово или фраза(может быть указанием на ячейку)
Dim lCol As Long 'номер столбца с просматриваемыми значениями
Dim lLastRow As Long, li As Long
Dim lMet As Long

sSubStr = InputBox("Укажите значение, которое необходимо найти в строке", "Запрос параметра", "")
If sSubStr = "" Then lMet = 0 Else lMet = 1
lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
If lCol = 0 Then Exit Sub


lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count

Application.ScreenUpdating = 0
For li = lLastRow To 1 Step -1
If -(InStr(Cells(li, lCol), sSubStr) > 0) = lMet Then Rows(li).Delete
Next li
Application.ScreenUpdating = 1
End Sub
можно ли сделать тоже самое, но только чтобы он удалял столбцы, по условию, которое он ищет в определенной строке??? [/more]

cfyrjcj

Код: Sub DelColumns()
Dim i&
sSubStr = InputBox("Укажите значение, которое необходимо найти в строке", "Запрос параметра", "")
With ActiveSheet.UsedRange
For i = .Columns.Count To 1 Step -1
If Not .Columns(i).Find(sSubStr, lookat:=xlWhole) Is Nothing Then .Columns(i).Delete
Next i
End With
End Sub

andrewkard1980

не помогло, может я что-то не то делаю, полностью ваш код записываю, как макрос в редакторе VB, может что-то еще надо добавить???