Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сравнение двух столбцов в разных книгах и добавление значений в первую книгу, не работает макрос
 
#1
18.01.2016 15:25:52
Добрый день!

Помогите, пожалуйста, разобраться почему не работает макрос и как исправить код. Я хочу сравнить столбец 3 из книги "Sample" со столбцом 2 из книги "Report", и если в Sample нет каких-то значений, добавить их туда. Примеры файлов во вложении.

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

Заранее большое спасибо!
Изменено: Александръ - 18.01.2016 17:15:59
 
 
 
#2
18.01.2016 15:27:45
Цитата
2.3. Приложите файл(ы) с примером (общим весом не более 100 Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#3
18.01.2016 15:36:08
Извините, исправился. Вроде и до этого облегчил файлы до предела, но оказалось, еще есть куда.
 
 
 
#4
18.01.2016 17:15:07
Если этот макрос уже не спасти, могу скинуть предыдущие макросы - было бы отлично, если бы хоть один из них заработал...
 
 
 
#5
18.01.2016 18:36:41
Код
Option Explicit
Sub Sample()
    Dim wbReport As Workbook
    Dim strFileName As Variant
    Dim rngSummary As Range, rngReport As Range, c As Range
    Dim arrInput(), arr(), i
              
    strFileName = Application.GetOpenFilename _
        ("Excel files(*.xls*),*.xls*", 1, "Ïîæàëóéñòà, âûáåðèòå Excel ôàéë", , False)
    
    If VarType(strFileName) = vbBoolean Then
        MsgBox ("Ôàéë íå âûáðàí")
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    With ThisWorkbook.Worksheets("sea")
        Set rngSummary = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))
    End With
    
    Set wbReport = Workbooks.Open(strFileName)
    With wbReport.Worksheets("Sheet1")
        Set rngReport = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
    End With
    
    arrInput = rngReport.Value
    
    ReDim Preserve arr(0)
    For Each i In arrInput
        Set c = rngSummary.Find(What:=i, LookIn:=xlValues)
        If c Is Nothing Then
            arr(UBound(arr)) = i
            ReDim Preserve arr(UBound(arr) + 1)
        End If
    Next i
    ReDim Preserve arr(UBound(arr) - 1)
    wbReport.Close False
    
    With rngSummary
        .Cells(.Rows.Count + 1, 1).Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
    End With
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
KL
 
 
 
#6
18.01.2016 18:49:15
Спасибо большое! Я так понимаю, мой вариант совсем корявым был и не имеет смысла даже спрашивать, почему он не работал? Столько времени на него потратил...
 
 
 
#7
18.01.2016 19:05:42
Возможно ваш вариант можно было подправить, но он использовал заведомо медленный алгоритм, да и время у меня ограничено :)
KL
 
 
 
#8
18.01.2016 19:15:57
Подскажите, пожалуйста, а как в случае с массивами добавить условие на проверку шестого столбца в файле Report, как было у меня в макросе:

If Cells(i, 2).Offset(, 4) = "BRV" Then

Я правильно понимаю, это должно быть как исправления ниже?
Код
Set wbReport = Workbooks.Open(strFileName)
    With wbReport.Worksheets("Sheet1")
        Set rngReport = .Range(.Cells(2, 6), .Cells(.Rows.Count, 2).End(xlUp))
    End With
     
    arrInput = rngReport.Value
     
    ReDim Preserve arr(4)
    For Each i In arrInput
        Set c = rngSummary.Find(What:=i, LookIn:=xlValues)
        If c(1, 1) Is Nothing Then
                  If с(1, 4) = "BRV" Then
                      arr(UBound(arr)) = i
                      ReDim Preserve arr(UBound(arr) + 1)
                 End If
        End If
    Next i
    ReDim Preserve arr(UBound(arr) - 1)
    wbReport.Close False
     
    With rngSummary
        .Cells(.Rows.Count + 1, 1).Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
    End With
Изменено: Александръ - 18.01.2016 19:22:01
 
 
 
#9
18.01.2016 20:47:07
Код
Option Explicit
Sub Sample()
    Dim wbReport As Workbook
    Dim strFileName As Variant
    Dim rngSummary As Range, rngReport As Range, c As Range, cell As Range
    Dim arr()
              
    strFileName = Application.GetOpenFilename _
        ("Excel files(*.xls*),*.xls*", 1, "Ïîæàëóéñòà, âûáåðèòå Excel ôàéë", , False)
    
    If VarType(strFileName) = vbBoolean Then
        MsgBox ("Ôàéë íå âûáðàí")
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    With ThisWorkbook.Worksheets("sea")
        Set rngSummary = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))
    End With
    
    Set wbReport = Workbooks.Open(strFileName)
    With wbReport.Worksheets("Sheet1")
        Set rngReport = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
    End With
    
    ReDim Preserve arr(0)
    For Each c In rngReport
        If c.Offset(, 4).Value = "BRV" Then
            Set cell = rngSummary.Find(What:=c.Value, LookIn:=xlValues)
            If cell Is Nothing Then
                arr(UBound(arr)) = c.Value
                ReDim Preserve arr(UBound(arr) + 1)
            End If
        End If
    Next c
    ReDim Preserve arr(UBound(arr) - 1)
    wbReport.Close False
    
    With rngSummary
        .Cells(.Rows.Count + 1, 1).Resize(UBound(arr) + 1).Value = Application.Transpose(arr)
    End With
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Изменено: KL - 18.01.2016 20:47:59
KL
 
 
 
#10
19.01.2016 00:54:29
А у меня есть решение, где всё можно сделать одним нажатием кнопки, — и значения подставить, и недостающие строки добавить:
http://excelvba.ru/programmes/Lookup
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#11
19.01.2016 14:12:58
Цитата
KL написал: If cell Is Nothing Then
    arr(UBound(arr)) = c.Value
    ReDim Preserve arr(UBound(arr) + 1)
End If
Я прошу прощения, последний вопрос: а как правильно прописать, чтобы помимо целевой ячейки добавлялась также ячейка Cells(i, 2).Offset(, 1)? Т.е. первая ячейка, которая стоит справа от заданной.

Прошу прощения, что сразу не уточнил данный вопрос - в процессе доработки  придумал, как еще можно оптимизировать файл...
 
 
 
Страницы: 1
Читают тему
Наверх