» Excel VBA (часть 3)

mcdie>, спасибо, буду пробовать!

Цитата:

mcdie, спасибо за отклик!

"Затык" продолжается. Все глохнет на этом:


Цитата:
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & iBaseName & ".dbf", _
FileFormat:=xlDBF4, CreateBackup:=False


Вываливается Run-time error "1004"

Sale525, а ты библиотеку Scripting Runtime подключил в твоем проекте? т.к. ты используешь FSO: "iBaseName = CreateObject("Scripting.FileSystemObject").GetBaseName(AFile_Name) " Может в этом дело?

Господа,
есть экселевский файлик в нем есть несколько VBA модулей, классов, форм, как автоматически изменить содержимое этих модулей модулей, классов, форм на другие которые бурутся из других файлов, важен именно сам механизм как из вне добраться до содержимого vba проекта в xls файле.
Подскажите пожвлуйста

Добавлено:
ответ найден, все делается через
With ThisWorkbook.VBProject.VBComponents
.Remove .Item("Module1")
.Import Path & "CommonUtils"
End With

Нашел интересную возможность использования преобразования Фурье (БПФ) в VBA Excel [Ссылка]! для этого в рабочей книге Excel необходимо подключить пакет анализа (в 2007: главная кнопка -- параметры Excel – надстройки – управление -- параметры Excel – перейти – пакет анализа) и далее в проекте VBA подключить этот пакет (Tools – References – atpvbaen.xls), и при наборе кода в качестве функции писать, например, “Result = [atpvbaen.xls]. ” в появившемся всплывающем списке выбирать нужную функцию. Например, функция [atpvbaen.xls].Fourier(inputRng, outputRng) осуществляет БПФ. Можно делать БПФ в VBA по-другому [Ссылка]:
Sub SmallDemo()
Const FFT As String = "ATPVBAEN.XLA!Fourier"
Const Forward As Boolean = False

Run FFT, [A1:A8], [B1], Forward
End Sub

:>)
--
Dana DeLouis
Win XP & Office 2003

Удачи!

Здравствуйте.
Помогите пожалуйста решить вопрос.

В на листе есть две таблицы:
Таблица 1.
№ 1 2 3 4

DmitriyNVartovsk
Посмотри тут, я так понял что тебе нужно было через формулы сделать.
Ячейка А1- ввод номера человека
Ячейка D1 - результат в виде коэффициента
[Ссылка]

привет , помогите пожалуйста сделать макрос.
Есть список данных для выполнения циклической инвентаризации
Допустим это
f1
f2
f3
f4
f5
f6
f7
f8
f9
f10
f11
f12
f13
f14
f15
f16
f17
f18
f19
f20
f21
Каждый день , человек при запуске макроса должен получать результат:
3 рандомные ячейки должны копироваться на другой лист
при чем каждый день в течении недели , должны браться всегда разные 3 ячейки и они не должны повторятся в течении недели.
Т.е. при каждом запуске макроса должны копироваться 3 рандомные ячейки не совпадающие с предыдущими .
типа
Понедельник:
f1
f15
f20
Вторник:
f3
f9
f2
и т.д.

Возможно ли такое ?
Заранее спасибо.

DmitriyNVartovsk

Цитата:

Необходимо из певой таблицы взять данные о поле и возрасте и сравнить со второй таблицей и определить соответствующий коэффициент.

В каких диапазонах расположены таблицы? Куда помещать результат?

chupakabara
Можно
Во вспомогательном файле хранишь номер Weekday(Now) дня недели
В другом вспомогательном файле номера строк, уже выбранных на этой неделе, если первый день недели (новая неделя), то сбрасываешь список уже выбранных.
Остальные, не входящие в список уже использовавшихся (можно использовать Dictionary для удобства), грузишь в Collection и выбираешь случайно по индексу с удалением из коллекции выбранного и записью в файл уже использовавшихся. По числу записей в файле и номеру дня недели определяешь, не запустили ли макрос повторно.
Вспомогательные файлы можно заменить рабочим листом (скрытым от пользователя), могут и другие варианты быть, например, реестр

Цитата:

chupakabara
Можно
Во вспомогательном файле хранишь номер Weekday(Now) дня недели
В другом вспомогательном файле номера строк, уже выбранных на этой неделе, если первый день недели (новая неделя), то сбрасываешь список уже выбранных.
Остальные, не входящие в список уже использовавшихся (можно использовать Dictionary для удобства), грузишь в Collection и выбираешь случайно по индексу с удалением из коллекции выбранного и записью в файл уже использовавшихся. По числу записей в файле и номеру дня недели определяешь, не запустили ли макрос повторно.
Вспомогательные файлы можно заменить рабочим листом (скрытым от пользователя), могут и другие варианты быть, например, реестр

я не сильно разбираюсь в макросах, поэтому не совсем понял как это сделать.
Ячеек из которых нужно будет выбирать 70 тысяч.
Может мы можем списаться в icq или по почте ? Помогите написать макро, пожалуйста . очень нада .

Подскажите можно передать текстовое содержимое буфера обмена в переменную типа Variant VBA, а не на лист книги. Если да, как это сделать?

Добрый день. у меня есть задание, хотелабы обратиться за помощью. -Задание- Создать таблицу имен и фамилий в дательном падеже... у меня есть в именительном, а теперь надо в дательный. каким образом, спасибо.

KolyaP

Код:
Dim p As New DataObject
p.GetFromClipboard
Debug.Print p.GetText(1)

Цитата:

привет , помогите пожалуйста сделать макрос.
Есть список данных для выполнения циклической инвентаризации
Допустим это
f1
f2
f3
f4
f5
f6
f7
f8
f9
f10
f11
f12
f13
f14
f15
f16
f17
f18
f19
f20
f21
Каждый день , человек при запуске макроса должен получать результат:
3 рандомные ячейки должны копироваться на другой лист
при чем каждый день в течении недели , должны браться всегда разные 3 ячейки и они не должны повторятся в течении недели.
Т.е. при каждом запуске макроса должны копироваться 3 рандомные ячейки не совпадающие с предыдущими .
типа
Понедельник:
f1
f15
f20
Вторник:
f3
f9
f2
и т.д.

Возможно ли такое ?
Заранее спасибо.

Может кто помочь ? ооочень нада , пожалуйста.

С программированием не сильно дружу, помогите плиз в написании макроса (уверен, тут пару строчек).
Нужно взять 1-ый столбец, бесконечно длинный, и вычислить сумму каждой пятой его ячейки друг с другом и вывести эту сумму в ячейку другого столбца.
Заранее огромное спасибо.

summnx, бесконечно длинного не получится, максимум 65535 ячеек для Excel версии до 2007 Да и после ИМХО какое-то ограничение есть.

Способов на самом деле два:
1. Макрос

Код: Dim I as Long, Summ as Double
For I = 1 To Cells.SpecialCells(xlLastCell).Row Step 5
Summ = Summ + Cells(I, 1)
Next I
Cells(1,2) = Summ

Цитата:

KolyaP

Код:
Dim p As New DataObject
p.GetFromClipboard
Debug.Print p.GetText(1)

Спасибо! Уже нашёл этот способ.
Единственное примечание. Нужно сделать ещё такую процедуру:
через меню редактора макросов Tools -> References -> поставить галку напротив Microsoft Forms 2.0 Object Library

ZlydenGL

Спасибо, красивый код
Правда изменилось условие, нужно не сумму ячеек, а их среднее арифметическое, я попытался сам дополнить, но считается как-то неправильно
Не могли бы вы глянуть, в чем ошибка, пожалуйста.

Код:
Sub ggg()
Dim I As Long, Summ As Double, sred As Double
sred = 0
For I = 1 To Cells.SpecialCells(xlLastCell).Row Step 5
Summ = Summ + Cells(I, 1)
sred = sred + 1
Next I
Cells(1, 2) = Summ / sred
End Sub

summnx
xlLastCell - указывает на последнюю заполненную ячейку листа, а не на последнюю ячейку листа. Среднее значение в твоём случае будет завышено. Дели не на sred
а на 65535/5

Необходимо создать цикл Repeat until в excel, прикрепленный к определенным ячейкам, через макрос.
Помогите написать программный код.

chupakabara
Лист1: заполняем ячейки A1-A21 значениями f1-f21
Пример:
Лист2: Результат выполнения A2:G4 (столбцы - дни недели) - в текущий день недели будут копироваться 3 случайных неповторяющихся числа из Листа1 + сохранение книги.
Реализовано через сохранение данных во временные массивы.
[more]

Код:
*/
Dim DayOfW As Integer
DayOfW = Weekday(Now, vbMonday)
Dim I, J, D As Integer
Dim ArrB(1 To 3, 1 To 7) As String
Dim ArrA(1 To 21) As String
Dim ArrS(1 To 21) As Boolean
Dim ACount As Integer
Dim ARND As Integer
'сохранение во временные массивы
For J = 1 To 21
ArrA(J) = Sheets("Лист1").Cells(J, 1)
ArrS(J) = False
Next J
For D = 1 To 7
For I = 1 To 3
ArrB(I, D) = Sheets("Лист2").Cells(I + 1, D)
Next I
Next D
ACount = 0
'расчёт повторяющихся значений
For J = 1 To 21
For D = 1 To 21
A1 = (D - 1) Mod 3 + 1
A2 = (D - 1) \ 3 + 1
If ArrA(J) = ArrB(A1, A2) Then
ArrS(J) = True
ACount = ACount + 1
Exit For
End If
Next D
Next J
ACount = 21 - ACount
'расчёт случайного значения по дню недели
For J = 1 To 3
S = ""
ARND = Int((ACount * Rnd) + 1)
For I = 1 To 21
If ArrS(I) = True Then
ARND = ARND + 1
ElseIf ARND = I Then
S = ArrA(I)
ArrS(I) = True
ACount = ACount - 1
End If
Next I
ArrB(J, DayOfW) = S
Next J
'вставка расчётных значений на Лист2
For D = 1 To 7
For I = 1 To 3
Sheets("Лист2").Cells(I + 1, D) = ArrB(I, D)
Next I
Next D
' + сохранение можно добавить чтобы данные о выполненном макросе сохранялись на Листе
ActiveWorkbook.Save
*/

mcdie
Дело в том, что там не фиксированная длина столбца, а ячейки постепенно заполняться будут, например 20000 ячеек заполненных, 20500 и т.д Можно как-нибудь посчитать автоматом?

Cells.SpecialCells(xlLastCell).Row - у тебя и считает последний заполненный столбец, но он также может быть и пустым (не всегда считается так как нужно), поэтому может вручную если постчитать последний, то правильнее будет

Пример:

Код: Sub ggg()
Dim I As Long, Summ As Double, sred As Double
sred = 0
Summ = 0
ACount = 1
While Trim(Cells(ACount, 1)) <> ""
ACount = ACount + 1
Wend
For I = 1 To (ACount - 1) Step 5
Summ = Summ + Cells(I, 1)
sred = sred + 1
Next I
Cells(1, 2) = Summ / sred
End Sub

Спасибо большое за помощь ZlydenGL и mcdie

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

Мне нужно исправить код, чтобы поиск в таких строках файла XML <item name="okpo" value="00109725" /> был по слову "okpo", а не по атрибутам value.

Сейчас код такой:

Цитата:

Dim nodeList As Object
Dim xmldoc As Object
Dim xmlNode As Object
Dim xmlNodeRazdel As Object
Dim xmlNodeStroka As Object
Set nodeList = xmldoc.selectNodes("*/title")
Set xmlNode = nodeList.Item(0).cloneNode(True)
okpo = xmlNode.childNodes(0).Attributes(1).Value

ниже пример файла XML

[more]<?xml version="1.0" encoding="utf-8" ?>
- <report code="610013001012" form="1" shifr="stk_un_p1" year="2010" period="11">
- <title>
<item name="okpo" value="00109725" />
<item name="name" value="ОАО "Омский"" />
<item name="leader_fio" value="Иванов В.В." />
<item name="responsible_post" value="экономист" />
<item name="responsible_fio" value="Гребенщиков В.А." />
<item name="phone" value="00-00-00" />
</title>
- <sections>
- <section code="1">
- <row code="1">
<col code="1">12051</col>
<col code="2">18498</col>
<col code="3">1118</col>
</row>
- <row code="15">
<col code="1">16</col>
</row>
- <row code="17">
<col code="1">18</col>
</row>
- <row code="19">
<col code="1">20</col>
</row>
</section>
- <section code="2">
[/more]
Не могу сделать, как искать по "okpo", был такой вариант текста:

Цитата:

For n = 0 To xmlNode.childNodes.Length - 1
If xmlNode.childNodes(n).nodeTypedValue = "okpo" Then
okpo = xmlNode.childNodes(0).Attributes(n).Value
End If
Next n

Но тоже не работает.

Omsk

Код:
Dim nextNode As Object, pItem As Object
Set xmlNode = xmlDoc.SelectSingleNode("*/title")

For Each nextNode In xmlNode.ChildNodes
Set pItem = nextNode.Attributes.getNamedItem("name")
If Not pItem Is Nothing Then
If pItem.NodeValue = "okpo" Then
Set pItem = nextNode.Attributes.getNamedItem("value")
If Not pItem Is Nothing Then Debug.Print pItem.NodeValue
End If
End If
Next nextNode

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

Код: Sub Test()
Dim a() As String, b() As String, i As Long, j As Long
j = Range("A65536").End(xlUp).Row ' Exel 2003
ReDim b(1 To j)

For i = 1 To j
ReDim a(1 To UBound(Split(Cells(i, 1).Value, " ", -1, vbTextCompare)))
a = Split(Cells(i, 1).Value, " ", -1, vbTextCompare)
b(i) = a(UBound(a))
Next i

For i = 1 To j
Debug.Print b(i) ' здесь укажите куда собираетесь выложить эти данные, _
хотя это можно сделать еще в первом цикле, но так как вы хотели получить массив?, пожалуйста пользуйтесь.
Next i
End Sub

Excel 2003:

При нажатии на кнопку необходимо выделить 2 разных участка ("A1:D1" и "A3:D3") и далее скопировать объединение этих участков.

Имеем код:

Код:
Dim r1 As Range, r2 As Range, r3 As Range
Worksheets("Лист1").Activate
Set r1 = Range("A1:D1")
Set r2 = Range("A3:D3")
Set r3 = Union(r1, r2)
r3.Select
r3.Copy

Если я не ошибаюсь, то эти черные полоски обозначают именно выделение при "вырезании" или "копировании", поэтому я предполагаю что выделение не пропало. Вопрос в том, чего именно, вы пытаетесь достичь,? возможно этот вопрос можно решить каким-то другим образом. Опишите ваши последующие действия.