доработка макроса для поиска строки по условию

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

NICK31

Дата: Четверг, 07.06.2012, 09:46 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 112

Репутация: 0 ±

Замечаний: 0% ±

Есть файл «списание» и есть макрос, но макрос сделан к другому файлу ЮЛ! Как можно переделать макрос, чтобы он искал строчки в файле «списание» со словами «беспроц», «безпроц», «б/процен» (условие выполняется неодновременно, а так чтобы хотя бы одно из слов встречалось в строчке) и найденную строчку полностью со столбца J переносил на лист 2 файла «списание»!

К сообщению приложен файл: 1508921.rar (37.1 Kb)

Ответить

NICK31

Дата: Четверг, 07.06.2012, 16:24 | Сообщение № 2

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 112

Репутация: 0 ±

Замечаний: 0% ±

[code]Sub КОПИРОВАТЬ()
iPath$ = ActiveWorkbook.Path & "\"
iFile$ = Dir(iPath$ & "списание.xl?")
iList$ = "Лист1"
If iFile$ = "" Then
MsgBox " Не найден файл списание.xl?! ПРОЦЕДУРА ПРЕРВАНА "
Exit Sub
End If
Dim OTKUDA As Range, PS, I
Dim KUDA As Range, sz
Application.ScreenUpdating = False
IName = "списание.xl?"
iMacroFunction = "DOCUMENTS(3,""" & IName & """)"
iWorkbookName = ExecuteExcel4Macro(iMacroFunction)
If Not IsError(iWorkbookName) Then
'MsgBox "Рабочая книга открыта"
Windows(iWorkbookName).Activate
Else
'MsgBox "Рабочая книга закрыта"
Workbooks.Open Filename:=iPath$ & iFile$
End If
PS = Sheets("Лист2").Range("J" & Rows.Count).End(xlUp).Row + 5
Sheets("Лист2").Range("J2:AB" & PS).ClearContents
Sheets("Лист1").Select
PS = Range("J" & Rows.Count).End(xlUp).Row
sz = 1
For I = 5 To PS
ww = Val(Replace(Cells(I, 17), ChrW(160), ""))
If Cells(I, 4) Like "*беспроц*" Or Cells(I, 4) Like "*безпроц*" Or Cells(I, 4) Like "*б/процен*" Then
Set OTKUDA = Range("J" & I & ": AB" & I)
Set KUDA = Sheets("Лист2").Range("A" & sz & ": W" & sz)
OTKUDA.Copy KUDA
sz = sz + 1
End If
Next I
Application.ScreenUpdating = True
Sheets("Лист2").Select
End Sub
не получается

Ответить

NICK31

Дата: Четверг, 07.06.2012, 16:27 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 112

Репутация: 0 ±

Замечаний: 0% ±

изменил параметры поиска строки, но там при запуске почему то названия столбцов только копирует, хотя мне они вообще не нужны...нужны уже готовые строчки без названия столбцов

Ответить

NICK31

Дата: Четверг, 07.06.2012, 16:39 | Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 112

Репутация: 0 ±

Замечаний: 0% ±

не, вы не тот файл взяли!нужно с файла списание копировал строчки на 2 лист этого же файла

Ответить

NICK31

Дата: Четверг, 07.06.2012, 16:45 | Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 112

Репутация: 0 ±

Замечаний: 0% ±

вот эти 2 файла

К сообщению приложен файл: 2___.rar (27.0 Kb)

Ответить

_Boroda_

Дата: Четверг, 07.06.2012, 16:54 | Сообщение № 6

Группа: Админы

Ранг: Местный житель

Сообщений: 16715

Репутация: 6504 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

А, теперь понял. Тада так (не переделывая макрос, а просто меняя в нем названия и ссылки)
[vba]

Code

Sub КОПИРОВАТЬ()
    iPath$ = ActiveWorkbook.Path & "\"
    iFile$ = Dir(iPath$ & "списание.xl?")
    iList$ = "Лист1"
    If iFile$ = "" Then
       MsgBox " Не найден файл списание.xl?! ПРОЦЕДУРА ПРЕРВАНА "
       Exit Sub
    End If
    Dim OTKUDA As Range, PS, I
    Dim KUDA As Range, sz
    Application.ScreenUpdating = False
    IName = "списание.xl?"
    iMacroFunction = "DOCUMENTS(3,""" & IName & """)"
    iWorkbookName = ExecuteExcel4Macro(iMacroFunction)
    If Not IsError(iWorkbookName) Then
       'MsgBox "Рабочая книга открыта"
       Windows(iWorkbookName).Activate
    Else
       'MsgBox "Рабочая книга закрыта"
       Workbooks.Open Filename:=iPath$ & iFile$
    End If
    PS = Sheets("Лист2").Range("J" & Rows.Count).End(xlUp).Row + 5
    Sheets("Лист2").Range("A5:AP" & PS).ClearContents
    Sheets("Лист1").Select
    PS = Range("J" & Rows.Count).End(xlUp).Row
    sz = 1
    For I = 5 To PS
      ww = Val(Replace(Cells(I, 17), ChrW(160), ""))
      If Cells(I, 10) Like "*беспроц*" Or Cells(I, 4) Like "*безпроц*" Or Cells(I, 4) Like "*б/процен*" Then
         Set OTKUDA = Range("A" & I & ": AP" & I)
         Set KUDA = Sheets("Лист2").Range("A" & sz & ": AP" & sz)
         OTKUDA.Copy KUDA
         sz = sz + 1
      End If
    Next I
    Application.ScreenUpdating = True
    Sheets("Лист2").Select
End Sub

[/vba]

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995