» Excel VBA (часть 3)

smirnvlad

Добрый день и большое спасибо!
Работает

Добрый день!
Нужна помощь.
Для отслеживания изменения значений в ячейках использую функцию Worksheet_SelectionChange(ByVal Target As Range).
В зависимости от введенного текста в следующей строке (под измененной ячейкой) ставится число.
При ручном вводе все, естественно, работает отлично, но если текст вводится в первую ячейку, а дальше растягивается автозаполнением, то число под первой и второй ячейкой ставится, а под остальными ячйками автозаполненного диапазона никаких изменений. Как это исправить?
То есть суть вопроса: как отслеживать изменение ячеек, если они изменились путем автозаполнения?

P.S. Может где-то здесь уже подобный вопрос задавался, но поиском я найти не смог...

Hatab03

Цитата:

Для отслеживания изменения значений в ячейках использую функцию Worksheet_SelectionChange(ByVal Target As Range).

SelectionChange это когда выделяется другая ячейка, а не изменяется значение

Цитата:

Как это исправить?

показать неработающий код

smirnvlad


Цитата:

SelectionChange это когда выделяется другая ячейка, а не изменяется значение

Конечно же используется Worksheet_Change(ByVal Target As Range), ошибся.


Цитата:

показать неработающий код

там код не маленький (по моим меркам), но вот кусок идентичного кода:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False

x = Target.Row
y = Target.Column
If Cells(x, y) = "Я" Or Cells(x, y) = "ОД" Or Cells(x, y) = "ДО" Then
Cells(x + 1, y) = 4
Else: If Cells(x, y) = "ОЖ" Then Cells(x + 1, y) = 2 Else Cells(x + 1, y) = ""
End If


Application.EnableEvents = True

End Sub

Если пишу "Я" в ячейке А2, то в А3 ставится "4". потом растягиваю ячейку А2 дальше по строке. В ячейке B3 при этом ставится цифра 4, а дальше никаких изменений.

P.S. Хотел прикрепить пример файла, но что-то не могу найти как %)

Hatab03
[more]
Код: [no]
Function NewValue(V)
Select Case V
Case "Я", "ОД", "ДО":
NewValue = 4
Case "ОЖ":
NewValue = 2
End Select
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False

For Each C In Target
C.Rows(2).Value = NewValue(C)
Next

Application.EnableEvents = True
End Sub
[/no]

smirnvlad
Работает!
Огромное спасибо.
Сейчас только маленько поправлю это под свои нужды и вуаля

Как открыть каждый текстовый файл в каталоге, содержащие по одной строчке, и загрузить в определённые строчки таблицы, разбив на ячейки учитывая разделители (;), с минутной периодичностью?

faust2k
[more]
После записи макроса открытия файла с разделителями (;)
Workbooks.OpenText Filename:="C:\1.txt", Origin:= _
1251, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False _
, Space:=False, Other:=False,
TrailingMinusNumbers:=True

Конечно, тут еще не в определенные строчки таблицы загружаются данные, но эта обработка должна уже пойти вторым этапом. Т.е. предварительно загрузить данные на скрытую (невидимую страницу) а из неё загружать в нужную таблицу.
а про обновление каждую минуту, я только знаю что есть событие
Application.OnTime которое должно помочь.

http://forum.ru-board.com/topic.cgi?forum=33&topic=8273&start=260 - тут есть немного про встроенный таймер Excel со ссылкой
[/more]

mcdie
Именно такой код я получил при записи макроса, это просто. Интересует в первую очередь: 1) как посчитать файлы в каталоге и спарсить из имена 2) открыть, забрать содержимое, разбить по ячейкам и вставить в нужную строчку. Так как это периодические действия, т.е. каждые несколько секунд, нужно, чтобы процесс происходил наиболее простым методом, без нагрузки на систему, без создания промежуточных файлов.

faust2k
Вот макрос (mac123), который выводит поочереди имена файлов и считает их кол-во в каталоге "С" (пример взят с Ссылка с моим добавлением):
ВНИМАНИЕ: перед использованием необходимо подключить библиотеку Microsoft Scripting Runtime к используемому проекту (зайти в среде разработки в меню "Tools\References..." и выбрать данную библиотеку, если ее не будет, то через "Browse..." добавить файл C:\WINDOWS\system32\scrrun.dll, либо из папки ...system...)

Код: Sub mac123()
'
' mac123 Макрос
'
'
' Call to test GetFiles function.

Dim dctDict As New Scripting.Dictionary 'создается объект Dictionary
Dim varItem As Variant

' Call non recursively, return files into Dictionary object.
If GetFiles("C:\", dctDict, False) Then 'заполняется объект Dyctionary: dctDict
' Print items in dictionary.
For Each varItem In dctDict
Debug.Print varItem
Next
End If
MsgBox dctDict.Count 'Выводит кол-во файлов в "C:\"
End Sub
---------------------------------------------------------------------------------------
Function GetFiles(strPath As String, _
dctDict As Scripting.Dictionary, _
Optional blnRecursive As Boolean) As Boolean

' This procedure returns all the files in a directory into
' a Dictionary object. If called recursively, it also returns
' all files in subfolders.

Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File

' Return new FileSystemObject.
Set fsoSysObj = New FileSystemObject

On Error Resume Next
' Get folder.
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' Incorrect path.
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0

' Loop through Files collection, adding to dictionary.
For Each filFile In fdrFolder.Files
dctDict.Add filFile.Path, filFile.Path
MsgBox filFile.Path ' Выводит сообщением имя каждого файла, встретившегося в каталоге strPath, т.е. "C:\"
Next filFile

' If Recursive flag is true, call recursively.
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If

' Return True if no error occurred.
GetFiles = True

GetFiles_End:
Exit Function
End Function

А можно ли для решения моей задачи как то использовать этот пример http://www.excel-vba.ru/index.php?file=VBA_func_FILE?

faust2k, видимо можно. Не знаю, надо пробовать. Не пользовался такими еще


Добавлено:
хотя, судя по описанию функции Dir, нельзя, т.к. она только возвращает путь к некоторым файлам, папкам по определенному атрибуту: только чтение, системный и т.п. и возвращает она имя только одного файла, видимо, первого попавшегося:

Код: Sub macr1()
Dim strName As String

strName = Dir("C:\")
MsgBox strName
End Sub

faust2k
из каждого файла с одной строкой, в папке C:\temp, вставит значения на лист каждое в свою ячейку
если запустить не ParseFiles(), а StartScript() будет выполняться каждую минуту, до выполнения StopScript()
[more]
Код: [no]
Dim NextTime

Function ParseFiles()
DirPath = "C:\Temp\"
Filename = Dir(DirPath & "\*.txt")
i = 0
Do
ff = FreeFile
Open DirPath & "\" & Filename For Input As #ff
Line Input #ff, S1
If EOF(ff) Then
Sv = Split(S1, ";")
i = i + 1
Set rng = Cells(i, 1).Resize(1, UBound(Sv) + 1)
rng.Value = Sv
rng.Value = rng.Value
End If
Close #ff
Filename = Dir()
Loop Until Filename = ""
End Function

Sub StartScript()
On Error GoTo NewTime
ParseFiles
NewTime:
NextTime = Now + TimeValue("00:01:00")
Application.OnTime EarliestTime:=NextTime, Procedure:="StartScript"
End Sub

Sub StopScript()
On Error Resume Next
Application.OnTime EarliestTime:=NextTime, Procedure:="StartScript", Schedule:=False
End Sub
[/no]

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

smirnvlad, спасибо. на первый взгляд похоже на правду ))

smirnvlad, интересный пример ты привел. Не понятно только, что такое "ff = FreeFile", что за тип данных у ff и что такое FreeFile? Спасибо.

vaulin
open открывает файлы под номерами
FreeFile возвращает свободный номер

[more=FreeFile help]Returns an Integer representing the next file number available for use by the Open statement.

Syntax

FreeFile[(rangenumber)]

The optional rangenumber argument is a Variant that specifies the range from which the next free file number is to be returned. Specify a 0 (default) to return a file number in the range 1 – 255, inclusive. Specify a 1 to return a file number in the range 256 – 511.

Remarks

Use FreeFile to supply a file number that is not already in use.
[/more]

vaulin faust2k
[more=Get All Files using DIR]Function GetAllFilesInDir(ByVal strDirPath As String) As Variant
' Loop through the directory specified in strDirPath and save each
' file name in an array, then return that array to the calling
' procedure.
' Return False if strDirPath is not a valid directory.
Dim strTempName As String
Dim varFiles() As Variant
Dim lngFileCount As Long

On Error GoTo GetAllFiles_Err

' Make sure that strDirPath ends with a "\" character.
If Right$(strDirPath, 1) <> "\" Then
strDirPath = strDirPath & "\"
End If

' Make sure strDirPath is a directory.
If GetAttr(strDirPath) = vbDirectory Then
strTempName = Dir(strDirPath, vbDirectory)
Do Until Len(strTempName) = 0
' Exclude ".", "..".
If (strTempName <> ".") And (strTempName <> "..") Then
' Make sure we do not have a sub-directory name.
If (GetAttr(strDirPath & strTempName) _
And vbDirectory) <> vbDirectory Then
' Increase the size of the array
' to accommodate the found filename
' and add the filename to the array.
ReDim Preserve varFiles(lngFileCount)
varFiles(lngFileCount) = strTempName
lngFileCount = lngFileCount + 1
End If
End If
' Use the Dir function to find the next filename.
strTempName = Dir()
Loop
' Return the array of found files.
GetAllFilesInDir = varFiles
End If
GetAllFiles_End:
Exit Function
GetAllFiles_Err:
GetAllFilesInDir = False
Resume GetAllFiles_End
End Function


Sub TestGetAllFiles()
Dim varFileArray As Variant
Dim lngI As Long
Dim strDirName As String


Const NO_FILES_IN_DIR As Long = 9
Const INVALID_DIR As Long = 13

On Error GoTo Test_Err

strDirName = "E:\FSB\Plots"
varFileArray = GetAllFilesInDir(strDirName)
For lngI = 0 To UBound(varFileArray)
Debug.Print varFileArray(lngI)

Documents.Open strDirName & "\" & varFileArray(lngI)
MsgBox "Name of this drawing is: " & ThisDrawing.Name
ActiveDocument.Close , varFileArray(lngI)

Next lngI
[/more]
[more=Get specific files using DIR]Private Sub Command1_Click()
Dim files() As String
If (FindFiles("c:\windows\system32\", "dll", files) = True) Then
MsgBox "Files found: " & UBound(files) & vbCrLf & vbCrLf & _
"1st file: " & files(0) & vbCrLf & _
"2nd file: " & files(1)
End If
End Sub
Private Function FindFiles(ByVal path As String, ByVal ext As String, ByRef files() As String) As Boolean
Dim ffile As String
ffile = Dir$(path & "*." & ext)
Do
If (ffile <> vbNullString) Then
If (FindFiles = False) Then
ReDim files(0) As String
FindFiles = True
Else
ReDim Preserve files(UBound(files) + 1) As String
End If
files(UBound(files)) = ffile
ffile = Dir
Else
Exit Do
End If
Loop Until (ffile = vbNullString)
End Function
[/more]

Не обращаем внимание

Надо написать макрос для Excel 2003 чтобы после нажатия на кнопку прошло 3 секунды и затем активировался заданный лист (Лист2.Activate)

Находил разные варианты содержания задержки, например

1) Application.Wait Now + TimeValue("0:00:03").

2) Declare Sub Sleep Lib "kernel32" Alias "Sleep" _
(ByVal dwMilliseconds As Long)

Sleep 3000

Но есть проблема: пока идет задержка невозможно переключиться на другое окно Excel или страницу текущей книги.

Dmitriy05
1. не дожидаясь пока пользователь завершит свои действия. например, редактирование ячейки

Код:
stoptime = Now + TimeValue("00:00:03")
Do
DoEvents
Loop Until Now >= stoptime

Лист2.Activate

smirnvlad
Первый макрос во время работы не дает перейти на другой файл.

Вопрос по второму: его надо запусктаь вот так?

Цитата:

Sub b()
Лист2.Activate
End Sub


Sub Кнопка1_Щелкнуть()
'
' Кнопка1_Щелкнуть Макрос
' Макрос записан 14.11.2010 (Dimas)
'
Application.OnTime EarliestTime:=Now + TimeValue("00:00:03"), Procedure:="b"

End Sub

Если да, то он имеет недостаток - при октрытии Лист2 он уводит меня с текущего файла на тот где работает макрос.

Dmitriy05
можно второй файл открыть в другом excel (запустить excel через ярлык, потом открыть файл)
или так

Код:
Sub b()
On Error Resume Next
Set awb = Application.ActiveWorkbook
Application.ScreenUpdating = False
Лист2.Activate
awb.Activate
Application.ScreenUpdating = True
End Sub


Sub Кнопка1_Щелкнуть()
Application.OnTime EarliestTime:=Now + TimeValue("00:00:03"), Procedure:="b"
End Sub

smirnvlad
Вот этот уже лучше!
Просто у меня открыто 2 файла, в одном нажал кнопку - перешел на второй, а в первом активируеться другой лист.

Завтра посмотрю будет ли мешать небольшое "мигание" при окночании таймаута - кусор быстро меяет форму на песочные часы и обратно.

Заранее спасибо!

Ребята помогите с макрос который позволил бы консолидировать два листа в разных файлах, один ньюанс - шапка у листов одинаковая, но количество столбцов под шапкой заполнена в листах заполнена по разному, пример:

лист1
дата значение1 значение2 значение3 значение4 значение5
1/1/10 "данные1" "данные1"


лист2
дата значение1 значение2 значение3 значение4 значение5
1/1/10 "данные2"


необходимо получить в конце

дата значение1 значение2 значение3
1/1/10 "данные1" "данные1" "данные2"

т.е. под шапку заполнить данные из другого листа ( соответствующие названию шапки)

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

Цитата:

Как открыть каждый текстовый файл в каталоге, содержащие по одной строчке, и загрузить в определённые строчки таблицы, разбив на ячейки учитывая разделители (;), с минутной периодичностью?

Цитата:

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

faust2k, вот еще вариантик решения твоей задачи:


Код: Sub macro1()
' Макрос открывает файлы с именами, записанными в strFiles,
' читает содержимое, разделяет содержимое по разделителю ";"
' и записывает это содержимое в строки. Повторяет это через
' время PauseTime (секунды)
' Записан vin

Dim MyChar As String, strTmp As String, ArrLength As Long
Dim i As Integer, j As Integer, k As Integer, step As Integer
Dim strFiles(3) As String, strPath As String
Dim PauseTime, Start, Finish, TotalTime

On Error GoTo handleCancel ' Прерывание программы по нажатию Ctrl+Breake
Application.EnableCancelKey = xlErrorHandler
MsgBox "This may take a long time: press Ctrl+Breake to cancel. Для прерывания программы, нажмите Ctrl+Breake"

strPath = "F:\Work\temp\"
strFiles(1) = strPath & "Текстовый документ.txt"
strFiles(2) = strPath & "Текстовый документ (2).txt"
strFiles(3) = strPath & "Текстовый документ (3).txt"

ArrLength = UBound(strFiles) - LBound(strFiles) 'длина массива с именами файлов, strFiles
i = 1 ' Пременные для задания строк таблицы,
k = 0 ' в кот. будут записываться значения
step = 6 ' из файлов
Do
For j = 1 To ArrLength
Open strFiles(j) For Input As #j 'Открываем файл функцией Open() на чтение
Do While Not EOF(j)
strTmp = Input(1, #j) 'считывание очередного символа из файла
If (strTmp <> ";") Then 'читается все, кроме разделителя ";"
MyChar = MyChar & strTmp ' Получаем по одному символу и добавляем его к предыдущим
End If
If ((strTmp = ";") Or EOF(j)) Then
'запись считанных значений в определенные строки
Worksheets("Лист1").Cells(i + (j - 1) * ArrLength + k, 1).Value = LTrim(MyChar)
MyChar = ""
i = i + 1
End If
Loop
Close #j ' Закрываем файл
Next
PauseTime = 3 ' Пауза в секундах
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
DoEvents ' Позволяем другим процессам работать
Loop
k = k + step ' Сдвиг по строкам
Loop

handleCancel: 'Прерывание выполнения программы после нажатия Ctrl+Breake
If Err = 18 Then
MsgBox "Game over!"
End If
End Sub

vaulin, спасибо и за этот пример тоже код от smirnvlad работает на ура.

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

faust2k
Для начала попробуй поменять тип ячеек. Если не поможет -- для всех ячеек сделай что-то такое:

Код: Cells(i, j).Value = Cells(i, j).Value

faust2k
подправил пример
вместо Input #ff, S1
нужно Line Input #ff, S1
на случай, если первое значение в строке - число, а не текст

добавил Cells.value = Cells.Value, для добавленных ячеек
чтобы числа перестали быть текстом

вместо Cells(i, 1).Resize(1, UBound(Sv))
нужно Cells(i, 1).Resize(1, UBound(Sv) + 1)
чтобы не терять последний параметр в строке, если за ним нет ;

Цитата:

vaulin, спасибо и за этот пример тоже код от smirnvlad работает на ура

да, согласен, код от smirnvlad написан интересно, и место мало занимает; мне до такого далеко

Что за ошибка "Argument not optional", возникающая при возврате значения из функции? Где, что нужно поправлять?