Коприрование данных по ключевому слову - Мир MS Excel

Регистрация

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

= Мир MS Excel/Коприрование данных по ключевому слову - Мир MS Excel

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

Коприрование данных по ключевому слову (Макросы/Sub)

Коприрование данных по ключевому слову

Дата: Вторник, 08.07.2014, 16:23 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Доброго времени суток.
Подскажите пожалуйста как в виде кода VBA можно реализовать такое условие:
Найти в столбце "A" где содержится десяток производителей одного, например "Google" и все строки где будет указан данный производитель скопировать в другой фаил.
написал вот такой код

[vba]

Код

Dim wb1 As Object, wb2 As Object
Dim ra As Range: Application.ScreenUpdating = False

Set wb1 = Windows("rp074c_20140708_0414.xls").ActiveSheet
Set wb2 = Windows("Поставщики.xls").ActiveSheet

Application.ScreenUpdating = False
With wb1.UsedRange: .Value = .Value: End With

wb1.Activate
ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
"=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
"=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
wb1.Columns("CO:CT").Copy wb2.Columns("A:A")

wb1.Activate
ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
"=002 - Evyap International A.S. (Turkey)", Operator:=xlOr
wb1.Columns("CO:CT").Copy wb2.Worksheets("Лист2").Columns("A:A")

[/vba]

но есть проблема в последней строчки, я хочу скопировать данные с одного файла в другой фаил на второй лист

ЗЫ Код конечно немного туговат, может можно сделать чуточку по другому, буду весьма рад если покажите как.

Сообщение отредактировал Xaden - Вторник, 08.07.2014, 16:28

Ответить

Дата: Вторник, 08.07.2014, 17:26 | Сообщение № 2

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Извиняюсь, в коде копирую не строки а столбцы, но хотелось бы узнать именно про этот кусок

[vba]

Код

wb1.Columns("CO:CT").Copy wb2.Worksheets("Лист2").Columns("A:A")

[/vba]

почему не получается? Wb2 у меня как активный лист идет, я уже пробовал прописать

[vba]

Код

wb1.Columns("CO:CT").Copy Windows("Поставщики.xls").Sheet("Лист2").Columns("A:A")

[/vba]

Ничего не выходит

Сообщение отредактировал Xaden - Вторник, 08.07.2014, 17:29

Ответить

Дата: Вторник, 08.07.2014, 18:01 | Сообщение № 3

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

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

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

Excel 2010

а где пример?

Ответить

Дата: Вторник, 08.07.2014, 18:35 | Сообщение № 4

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

исходный фаил, откуда беру данные, весит более 70мб да и данные там такие, которые я не могу предоставить на всеобщие обозрение
Надеялся, что кода будет достаточно
Но если нужны именно файлы, попотею и сделаю что то наподобие

Сообщение отредактировал Xaden - Вторник, 08.07.2014, 18:36

Ответить

Дата: Вторник, 08.07.2014, 18:49 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

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

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

Сообщение отредактировал Xaden - Вторник, 08.07.2014, 18:59

Ответить

Дата: Вторник, 08.07.2014, 20:45 | Сообщение № 6

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

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

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

2010

[vba]

Код

Sub q()
      Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
      'Dim ra As Range
      Application.ScreenUpdating = False

      Set wb1 = Workbooks("rp074c_20140708_0414.xls")
      Set wb2 = Workbooks("Поставщики.xls")
      Set sh2 = wb2.ActiveSheet

      Application.ScreenUpdating = False
      With wb1
          .Activate
          .ActiveSheet.UsedRange .Value = .ActiveSheet.UsedRange.Value

          .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
                     "=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
          .ActiveSheet.Columns("CO:CT").Copy sh2.Range("A1")

          .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=002 - Evyap International A.S. (Turkey)", Operator:=xlOr
          .ActiveSheet.Columns("CO:CT").Copy wb2.Worksheets("Лист2").Range("A1")
      End With
End Sub

[/vba]

На засыпку
[vba]

Код

Application.FileDialog
Application.GetOpenFilename

[/vba]

PS А почему вы не указали, что тема на нескольких форумах?

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Вторник, 08.07.2014, 20:54

Ответить

Дата: Среда, 09.07.2014, 09:27 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Цитата RAN, 08.07.2014 в 20:45, в сообщении № 6

PS А почему вы не указали, что тема на нескольких форумах?

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

Ответить

Дата: Среда, 09.07.2014, 09:48 | Сообщение № 8

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Цитата RAN, 08.07.2014 в 20:45, в сообщении № 6

На засыпку
Application.FileDialog
Application.GetOpenFilename

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

Ответить

Дата: Среда, 09.07.2014, 10:07 | Сообщение № 9

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

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

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

2010

В том, что тема на нескольких форумах - ничего страшного. Плохо, что вы об этом не сообщили.

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Среда, 09.07.2014, 10:19 | Сообщение № 10

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Цитата RAN, 09.07.2014 в 10:07, в сообщении № 9

В том, что тема на нескольких форумах - ничего страшного. Плохо, что вы об этом не сообщили.

Возьму на заметку, если такое и повторится обязательно буду указывать сей факт

Ответить

Дата: Среда, 09.07.2014, 11:36 | Сообщение № 11

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

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

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

Excel 2010

вот вам ещё вариант

[vba]

Код

Sub Макрос1()
     Application.ScreenUpdating = False

     Dim wb1 As Workbook, wb2 As Workbook
     Dim SStr As String
     Dim Ci As Long, Cj As Long

     Set wb1 = ActiveWorkbook
     Workbooks.Open Filename:=Application.GetOpenFilename
     Set wb2 = ActiveWorkbook

     SStr = wb1.Sheets(1).Cells(3, 7)
     Ci = 1
     Cj = 1
     wb1.Sheets(2).Cells.Clear
     Do While wb2.Sheets(1).Cells(Ci, 1) <> ""
         If InStr(1, wb2.Sheets(1).Cells(Ci, 1), SStr, 1) Then
             wb2.Sheets(1).Rows(Ci).Copy
             wb1.Sheets(2).Activate
             Rows(Cj).Select
             ActiveSheet.Paste
             Cj = Cj + 1
         End If
         Ci = Ci + 1
     Loop

     Application.CutCopyMode = False
     wb2.Close SaveChanges:=False
     Application.ScreenUpdating = True
End Sub

[/vba]

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

Ответить

Дата: Среда, 09.07.2014, 12:21 | Сообщение № 12

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Цитата millik, 09.07.2014 в 11:36, в сообщении № 11

вот вам ещё вариант

Sub Макрос1()
    Application.ScreenUpdating = False

    Dim wb1 As Workbook, wb2 As Workbook
    Dim SStr As String
    Dim Ci As Long, Cj As Long

    Set wb1 = ActiveWorkbook
    Workbooks.Open Filename:=Application.GetOpenFilename
    Set wb2 = ActiveWorkbook

    SStr = wb1.Sheets(1).Cells(3, 7)
    Ci = 1
    Cj = 1
    wb1.Sheets(2).Cells.Clear
    Do While wb2.Sheets(1).Cells(Ci, 1) <> ""
        If InStr(1, wb2.Sheets(1).Cells(Ci, 1), SStr, 1) Then
            wb2.Sheets(1).Rows(Ci).Copy
            wb1.Sheets(2).Activate
            Rows(Cj).Select
            ActiveSheet.Paste
            Cj = Cj + 1
        End If
        Ci = Ci + 1
    Loop

    Application.CutCopyMode = False
    wb2.Close SaveChanges:=False
    Application.ScreenUpdating = True
End Sub

Сложноват для меня такой вариант, я еще плохо ориентируюсь в VBA
Но спасибо за потраченное время и усилие
ЗЫ попробовал Ваш макрос, копирование в вашем коде идет только на второй лист, а мне по сути надо допустим "Поставщик1" включая шапку перенести на лист1, Поставщик2 на лист2 и тд

Ответить

Дата: Среда, 09.07.2014, 12:57 | Сообщение № 13

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

А не подскажите уважаемые, как копировать скрытые столбцы? допустим у меня с A:N есть скрытые ячейки, что можно сделать что бы при копирование они тоде переносились, потому что сейчас у меня выходят пустые столбцы вместо данных которые я хочу перенести.

Ответить

Дата: Среда, 09.07.2014, 13:40 | Сообщение № 14

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Цитата Xaden, 09.07.2014 в 12:57, в сообщении № 13

А не подскажите уважаемые, как копировать скрытые столбцы? допустим у меня с A:N есть скрытые ячейки, что можно сделать что бы при копирование они тоде переносились, потому что сейчас у меня выходят пустые столбцы вместо данных которые я хочу перенести.

прошу прощения, что поспешил задавать столь глупый вопрос.
Нашел ответ на свой вопрос

Ответить

Дата: Среда, 09.07.2014, 14:39 | Сообщение № 15

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

[vba]

Код

Sub q()
     Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
     'Dim ra As Range
     Application.ScreenUpdating = False

    ' Set wb1 = Workbooks("rp074c_20140708_0414.xls")
     Set wb1 = ActiveWorkbook
     Workbooks.Open Filename:=Application.GetOpenFilename
     Set wb2 = Workbooks("Поставщики.xls")
     Set sh2 = wb2.ActiveSheet

     Application.ScreenUpdating = False
     With wb1
         .Activate
         .ActiveSheet.UsedRange .Value = .ActiveSheet.UsedRange.Value

         .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
                     "=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
         .ActiveSheet.Columns("CO:CT").Copy sh2.Range("A1")

         .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=002 - Evyap International A.S. (Turkey)", Operator:=xlOr
         .ActiveSheet.Columns("CO:CT").Copy wb2.Worksheets("Лист2").Range("A1")
     End With
End Sub

[/vba]

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

[vba]

Код

      .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
                     "=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
         .ActiveSheet.Columns("CO:CT").Copy sh2.Range("A1")

[/vba]

Не подскажите, чем это вызвано?
ЗЫ Если указываю именно путь к файлу, то весь макрос работает без проблем.

[vba]

Код

Sub q()
     Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
     'Dim ra As Range
     Application.ScreenUpdating = False

    ' Set wb1 = Workbooks("rp074c_20140708_0414.xls")
     Set wb1 = ActiveWorkbook
     Workbooks.Open Filename:=Application.GetOpenFilename
     Set wb2 = Workbooks("Поставщики.xls")
     Set sh2 = wb2.ActiveSheet

     Application.ScreenUpdating = False
     With wb1
         .Activate
         .ActiveSheet.UsedRange .Value = .ActiveSheet.UsedRange.Value

         .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
                     "=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
         .ActiveSheet.Columns("CO:CT").Copy sh2.Range("A1")

         .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=002 - Evyap International A.S. (Turkey)", Operator:=xlOr
         .ActiveSheet.Columns("CO:CT").Copy wb2.Worksheets("Лист2").Range("A1")
     End With
End Sub

[/vba]

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

[vba]

Код

      .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
                     "=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
         .ActiveSheet.Columns("CO:CT").Copy sh2.Range("A1")

[/vba]

Не подскажите, чем это вызвано?
ЗЫ Если указываю именно путь к файлу, то весь макрос работает без проблем.Xaden

Ответить

Сообщение[vba]

Код

Sub q()
     Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
     'Dim ra As Range
     Application.ScreenUpdating = False

    ' Set wb1 = Workbooks("rp074c_20140708_0414.xls")
     Set wb1 = ActiveWorkbook
     Workbooks.Open Filename:=Application.GetOpenFilename
     Set wb2 = Workbooks("Поставщики.xls")
     Set sh2 = wb2.ActiveSheet

     Application.ScreenUpdating = False
     With wb1
         .Activate
         .ActiveSheet.UsedRange .Value = .ActiveSheet.UsedRange.Value

         .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
                     "=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
         .ActiveSheet.Columns("CO:CT").Copy sh2.Range("A1")

         .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=002 - Evyap International A.S. (Turkey)", Operator:=xlOr
         .ActiveSheet.Columns("CO:CT").Copy wb2.Worksheets("Лист2").Range("A1")
     End With
End Sub

[/vba]

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

[vba]

Код

      .ActiveSheet.Range("$A$7:$EL$19984").AutoFilter Field:=2, Criteria1:= _
                     "=001 - Hayat Kimya Sanayi A.S. (Turkey)", Operator:=xlOr, Criteria2:= _
                     "=001b - Hayat Kimya Sanayi A.S. (Bulgaria)"
         .ActiveSheet.Columns("CO:CT").Copy sh2.Range("A1")

[/vba]

Не подскажите, чем это вызвано?
ЗЫ Если указываю именно путь к файлу, то весь макрос работает без проблем.

Автор - Xaden
Дата добавления - 09.07.2014 в 14:39

Дата: Среда, 09.07.2014, 20:52 | Сообщение № 16

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

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

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

2010

Цитата Xaden, 09.07.2014 в 14:39, в сообщении № 15

Не подскажите, чем это вызвано?

Подскажу. Вы что то делаете не так.
Если распишите, что вы вообще делаете (пошагово, лучше в виде комментария к макросу), то шансы должны сильно возрасти.

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Четверг, 10.07.2014, 09:31 | Сообщение № 17

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

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

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

Ответить

Дата: Четверг, 10.07.2014, 09:41 | Сообщение № 18

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3859

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

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

365

И где описание процесса?
А то непонятно - с какой стати собрались фильтровать пустой лист? Да и в коде один лишний пробел сидит в
[vba]

Код

.ActiveSheet.UsedRange .Value = .ActiveSheet.UsedRange.Value

[/vba] непонятным образом...

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Четверг, 10.07.2014, 11:07 | Сообщение № 19

Группа: Пользователи

Ранг: Участник

Сообщений: 73

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

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

Excel 2003

Цитата Hugo, 10.07.2014 в 09:41, в сообщении № 18

И где описание процесса?
А то непонятно - с какой стати собрались фильтровать пустой лист? Да и в коде один лишний пробел сидит в
.ActiveSheet.UsedRange .Value = .ActiveSheet.UsedRange.Value
непонятным образом...

Добрый день, лишний пробел видать забыл убрать.
Процес в целом такой, с файла "Исходник" мне нужно скопировать все столбцы в фаил "Поставщики"

И почему же пустой фаил собираюсь фильтровать? если я указываю что wb1 это фаил источник.
Если обратите внимание на закомментированный код, где я указываю точное название источника, макрос работает и копирует все очень даже хорошо.
А вот как только пытаюсь через [vba]

Код

Set wb1 = ActiveWorkbook
Workbooks.Open Filename:=Application.GetOpenFilename

[/vba]
Макрос отказывается работать

Сообщение отредактировал Xaden - Четверг, 10.07.2014, 11:08

Ответить

Дата: Четверг, 10.07.2014, 15:38 | Сообщение № 20

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

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

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

2010

Я не случайно написал

Цитата RAN, 09.07.2014 в 20:52, в сообщении № 16

Вы что то делаете не так.

Больше чем уверен, что конфликт в том, что делает макрос
[vba]

Код

Set wb1 = ActiveWorkbook

[/vba]
и тем, что делается вручную
[vba]

Код

Workbooks.Open Filename:=Application.GetOpenFilename

[/vba]
Но написать, что вы делаете, вы не написали. closed

closed

Быть или не быть, вот в чем загвоздка!

Ответить

Коприрование данных по ключевому слову (Макросы/Sub)

Страница 1 из 2
1
2
»

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