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

Вход

Регистрация

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

 

= Мир MS Excel/Сравнить две таблицы и скопировать все несовпадающие значени - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сравнить две таблицы и скопировать все несовпадающие значени (Макросы/Sub)
Сравнить две таблицы и скопировать все несовпадающие значени
Tunka-s Дата: Четверг, 11.07.2019, 11:31 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 124
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Дано:
1. Файл онлайн, который содержит кучу информации обо всех продуктах, большнство из которой пользователю не нужна.
2. Файл у пользователя, который содержит аналогичную информацию, но только касательно определенных продуктов
3. Первый файл апдейтится автоматически каждый день, забирая инфу из базы данных. Пользователь один раз в месяц должен сравнить продукты из своего файла, с аналогичными продуктами из обшего файла. Не появились ли новые, не устарели ли старые и внести все изменениы в свою локальную систему. Пользователь с vlookup не дружит, поэтому я решила автоматизировать процесс. Свой отчет он скопирует в файл руками, а информация из большого файла будет копироваться и сравниваться с его файлом при помощи макроса. Код я написалa/скомпилировала :) и он работает, но все циклы уж очень прямолинейные и примитивные. В итоге все мигает и крутится секунд 30, пока разродится финальной таблицей.

Не подскажете, пожалуйста, как бы этот процесс сделать менее заметным глазу? Спасибо.

[vba]
Код
Sub copy()

Dim Tube As String
Dim LastRow_ECAT As Integer
Dim LastRow_RIMS As Integer
Dim sShName As String, sAddress As String, vData

    Dim objCloseBook As Object
    
    Application.ScreenUpdating = False
    Workbooks.Open "https://terumoemea.sharepoint.com/sites/teamrooms/masterdatamanagement/eCatalogue/eProductCatalogue.xlsx"
    
    
    sAddress = "A1:I25000"
    
     vData = Sheets("Sheet1").Range(sAddress).Value
    ActiveWorkbook.Close False
    
    If IsArray(vData) Then
    
    Worksheets("E-Catalogue").Activate
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A1] = vData
    End If
    
        'Workbooks.Open Filename:="https://terumoemea.sharepoint.com/sites/teamrooms/masterdatamanagement/eCatalogue/eProductCatalogue.xlsx"

LastRow_ECAT = Worksheets("E-catalogue").UsedRange.Rows.Count
LastRow_RIMS = Worksheets("RIMS active codes").UsedRange.Rows.Count

'MsgBox (LastRow_ECAT)

Worksheets("Comparison").Activate

Worksheets("Comparison").Range("A2:E100000").Clear

For i = 2 To LastRow_ECAT

Tube = Worksheets("E-catalogue").Cells(i, 2).Value

Set A = Worksheets("RIMS active codes").Columns(2).Find(Tube, LookIn:=xlValues)
    
        If A Is Nothing Then
            
            If Left(Tube, 3) = "CX-" Then
            
            'PS = Range("A" & Rows.Count).End(xlUp).Row

                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1, 1).Value = Tube
            Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 2).Value = "New item. To add"
                
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 3).Value = Worksheets("E-catalogue").Cells(i, 5).Value
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 4).Value = Worksheets("E-catalogue").Cells(i, 7).Value
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 5).Value = Worksheets("E-catalogue").Cells(i, 8).Value
                
            End If

       End If

Next i

For i = 6 To LastRow_RIMS

Tube = Worksheets("RIMS active codes").Cells(i, 2).Value

Set A = Worksheets("E-catalogue").Columns(2).Find(Tube, LookIn:=xlValues)
    

        If A Is Nothing Then
            
            'If Left(Tube, 3) = "CX-" Then

                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1, 1).Value = Tube
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 2).Value = "Old item. Remove"
              
            
       End If

Next i

Columns("A:E").EntireColumn.AutoFit

    Cells(1, 6) = "Update : " & Now
    Cells(1, 6).Font.Bold = True
    Cells(1, 6).Font.Color = vbRed
  
Application.ScreenUpdating = True

End Sub
[/vba]
 
Ответить
СообщениеДано:
1. Файл онлайн, который содержит кучу информации обо всех продуктах, большнство из которой пользователю не нужна.
2. Файл у пользователя, который содержит аналогичную информацию, но только касательно определенных продуктов
3. Первый файл апдейтится автоматически каждый день, забирая инфу из базы данных. Пользователь один раз в месяц должен сравнить продукты из своего файла, с аналогичными продуктами из обшего файла. Не появились ли новые, не устарели ли старые и внести все изменениы в свою локальную систему. Пользователь с vlookup не дружит, поэтому я решила автоматизировать процесс. Свой отчет он скопирует в файл руками, а информация из большого файла будет копироваться и сравниваться с его файлом при помощи макроса. Код я написалa/скомпилировала :) и он работает, но все циклы уж очень прямолинейные и примитивные. В итоге все мигает и крутится секунд 30, пока разродится финальной таблицей.

Не подскажете, пожалуйста, как бы этот процесс сделать менее заметным глазу? Спасибо.

[vba]
Код
Sub copy()

Dim Tube As String
Dim LastRow_ECAT As Integer
Dim LastRow_RIMS As Integer
Dim sShName As String, sAddress As String, vData

    Dim objCloseBook As Object
    
    Application.ScreenUpdating = False
    Workbooks.Open "https://terumoemea.sharepoint.com/sites/teamrooms/masterdatamanagement/eCatalogue/eProductCatalogue.xlsx"
    
    
    sAddress = "A1:I25000"
    
     vData = Sheets("Sheet1").Range(sAddress).Value
    ActiveWorkbook.Close False
    
    If IsArray(vData) Then
    
    Worksheets("E-Catalogue").Activate
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A1] = vData
    End If
    
        'Workbooks.Open Filename:="https://terumoemea.sharepoint.com/sites/teamrooms/masterdatamanagement/eCatalogue/eProductCatalogue.xlsx"

LastRow_ECAT = Worksheets("E-catalogue").UsedRange.Rows.Count
LastRow_RIMS = Worksheets("RIMS active codes").UsedRange.Rows.Count

'MsgBox (LastRow_ECAT)

Worksheets("Comparison").Activate

Worksheets("Comparison").Range("A2:E100000").Clear

For i = 2 To LastRow_ECAT

Tube = Worksheets("E-catalogue").Cells(i, 2).Value

Set A = Worksheets("RIMS active codes").Columns(2).Find(Tube, LookIn:=xlValues)
    
        If A Is Nothing Then
            
            If Left(Tube, 3) = "CX-" Then
            
            'PS = Range("A" & Rows.Count).End(xlUp).Row

                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1, 1).Value = Tube
            Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 2).Value = "New item. To add"
                
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 3).Value = Worksheets("E-catalogue").Cells(i, 5).Value
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 4).Value = Worksheets("E-catalogue").Cells(i, 7).Value
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 5).Value = Worksheets("E-catalogue").Cells(i, 8).Value
                
            End If

       End If

Next i

For i = 6 To LastRow_RIMS

Tube = Worksheets("RIMS active codes").Cells(i, 2).Value

Set A = Worksheets("E-catalogue").Columns(2).Find(Tube, LookIn:=xlValues)
    

        If A Is Nothing Then
            
            'If Left(Tube, 3) = "CX-" Then

                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1, 1).Value = Tube
                Worksheets("Comparison").Cells(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row, 2).Value = "Old item. Remove"
              
            
       End If

Next i

Columns("A:E").EntireColumn.AutoFit

    Cells(1, 6) = "Update : " & Now
    Cells(1, 6).Font.Bold = True
    Cells(1, 6).Font.Color = vbRed
  
Application.ScreenUpdating = True

End Sub
[/vba]

Автор - Tunka-s
Дата добавления - 11.07.2019 в 11:31
_Boroda_ Дата: Четверг, 11.07.2019, 11:43 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 15401
Репутация: 6031 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Уберите Activate листов


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

Автор - _Boroda_
Дата добавления - 11.07.2019 в 11:43
Tunka-s Дата: Четверг, 11.07.2019, 12:57 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 124
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
_Boroda_, Убрала. Кроме того, что инфа из большого файла копируется теперь на лист с кнопкой "обновить отчет", а не на нужный и скрытый лист, никаких других изменений не заметила. Все так же крутится, мигает и тормозит.
 
Ответить
Сообщение_Boroda_, Убрала. Кроме того, что инфа из большого файла копируется теперь на лист с кнопкой "обновить отчет", а не на нужный и скрытый лист, никаких других изменений не заметила. Все так же крутится, мигает и тормозит.

Автор - Tunka-s
Дата добавления - 11.07.2019 в 12:57
_Boroda_ Дата: Четверг, 11.07.2019, 13:23 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 15401
Репутация: 6031 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Так не просто ж убрать и всё. Нужно указать листы для работы. Например, вместо
[vba]
Код
Worksheets("E-Catalogue").Activate
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
[/vba]
написать
[vba]
Код
Worksheets("E-Catalogue").range("A1").Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
[/vba]
А тормозит все верно - Вы всю работу проводите на листах. А нужно сначала данные засунуть в массивы, а потом с ними уже работать. Пример
[vba]
Код
ar1=Worksheets("E-catalogue").Cells(2, 2).resize(LastRow_ECAT-1).Value
[/vba]
А вместо Find сначала засунуть данные столбца для проверки в словарь и сверять в цикле по ar1
[vba]
Код
for i=1 to ubound ar1
      if not slov.exists(ar1(i,1)) then
          
     end if
next i
[/vba]
Ну и еще куча всякого, но без файлов, только по коду все это делать не очень интересно


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТак не просто ж убрать и всё. Нужно указать листы для работы. Например, вместо
[vba]
Код
Worksheets("E-Catalogue").Activate
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
[/vba]
написать
[vba]
Код
Worksheets("E-Catalogue").range("A1").Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
[/vba]
А тормозит все верно - Вы всю работу проводите на листах. А нужно сначала данные засунуть в массивы, а потом с ними уже работать. Пример
[vba]
Код
ar1=Worksheets("E-catalogue").Cells(2, 2).resize(LastRow_ECAT-1).Value
[/vba]
А вместо Find сначала засунуть данные столбца для проверки в словарь и сверять в цикле по ar1
[vba]
Код
for i=1 to ubound ar1
      if not slov.exists(ar1(i,1)) then
          
     end if
next i
[/vba]
Ну и еще куча всякого, но без файлов, только по коду все это делать не очень интересно

Автор - _Boroda_
Дата добавления - 11.07.2019 в 13:23
Tunka-s Дата: Четверг, 11.07.2019, 14:47 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 124
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
_Boroda_, Спасибо большое! Понятно направление движения. Попробую.
 
Ответить
Сообщение_Boroda_, Спасибо большое! Понятно направление движения. Попробую.

Автор - Tunka-s
Дата добавления - 11.07.2019 в 14:47
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сравнить две таблицы и скопировать все несовпадающие значени (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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