Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/доработка макроса для поиска строки по условию - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » доработка макроса для поиска строки по условию
доработка макроса для поиска строки по условию
NICK31 Дата: Четверг, 07.06.2012, 09:46 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 112
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - NICK31
Дата добавления - 07.06.2012 в 09:46
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
не получается
 
Ответить
Сообщение[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:24
NICK31 Дата: Четверг, 07.06.2012, 16:27 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 112
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - NICK31
Дата добавления - 07.06.2012 в 16:27
NICK31 Дата: Четверг, 07.06.2012, 16:39 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 112
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - NICK31
Дата добавления - 07.06.2012 в 16:39
NICK31 Дата: Четверг, 07.06.2012, 16:45 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 112
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - NICK31
Дата добавления - 07.06.2012 в 16:45
_Boroda_ Дата: Четверг, 07.06.2012, 16:54 | Сообщение № 6
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

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
 
Ответить
СообщениеА, теперь понял. Тада так (не переделывая макрос, а просто меняя в нем названия и ссылки)
[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_
Дата добавления - 07.06.2012 в 16:54
NICK31 Дата: Четверг, 07.06.2012, 17:01 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 112
Репутация: 0 ±
Замечаний: 0% ±

а как сделать, чтобы со столбца А он начанались скопированные данные на листе 2?
 
Ответить
Сообщениеа как сделать, чтобы со столбца А он начанались скопированные данные на листе 2?

Автор - NICK31
Дата добавления - 07.06.2012 в 17:01
_Boroda_ Дата: Четверг, 07.06.2012, 17:07 | Сообщение № 8
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Заполните в файле списание на листе 1 столбцы A:I
или, если не нужно, то
Set OTKUDA = Range("J" & I & ": AP" & I)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЗаполните в файле списание на листе 1 столбцы A:I
или, если не нужно, то
Set OTKUDA = Range("J" & I & ": AP" & I)

Автор - _Boroda_
Дата добавления - 07.06.2012 в 17:07
NICK31 Дата: Четверг, 07.06.2012, 17:13 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 112
Репутация: 0 ±
Замечаний: 0% ±

спасибо!и еще подскажите, а если слово "безпроцентный" пишется большими буквами, то как быть?я поменял на большие буквы, но он не скопировал
 
Ответить
Сообщениеспасибо!и еще подскажите, а если слово "безпроцентный" пишется большими буквами, то как быть?я поменял на большие буквы, но он не скопировал

Автор - NICK31
Дата добавления - 07.06.2012 в 17:13
NICK31 Дата: Четверг, 07.06.2012, 17:18 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 112
Репутация: 0 ±
Замечаний: 0% ±

строчки красным не скопировались
К сообщению приложен файл: 7843848.rar (27.5 Kb)
 
Ответить
Сообщениестрочки красным не скопировались

Автор - NICK31
Дата добавления - 07.06.2012 в 17:18
Мир MS Excel » Вопросы и решения » Вопросы по Excel » доработка макроса для поиска строки по условию
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!