Необходимо сопоставить значение столбца А со значением столбца D. В прикрепленном файле есть два листа "Исход" так сказать что имеем и "результат" то что должно получиться, выводить результат не обязательно на отдельный лист.
Необходимо сопоставить значение столбца А со значением столбца D. В прикрепленном файле есть два листа "Исход" так сказать что имеем и "результат" то что должно получиться, выводить результат не обязательно на отдельный лист.rayzer
Предварительно нужно добавить данные 2 квартала в третий, скопировав столбец А и вставив в столбцы D, в столбце Е сделайте пометку и затем надо выделить D:Е и удалить дубликаты. После получившиеся столбцы Д:Е скопировать на лист результат 2 в стлбцы Д:Е. Чтобы это не делать вручную вам макрос поможет.
Предварительно нужно добавить данные 2 квартала в третий, скопировав столбец А и вставив в столбцы D, в столбце Е сделайте пометку и затем надо выделить D:Е и удалить дубликаты. После получившиеся столбцы Д:Е скопировать на лист результат 2 в стлбцы Д:Е. Чтобы это не делать вручную вам макрос поможет.Richman
Sub Мяу() Dim arr, lr&, i&, k& lr = Cells(Rows.Count, "A").End(xlUp).Row arr = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp)).Resize(, 2).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) .Item(arr(i, 1)) = 1 Next lr = Cells(Rows.Count, "A").End(xlUp).Row i = 2 While i <= lr If Not .exists(Cells(i, "A").Value) Then Cells(i, "D").Resize(, 2).Insert Shift:=xlDown Else k = i While Cells(k, "A") <> Cells(k, "D") Cells(k, "A").Resize(, 2).Insert Shift:=xlDown k = k + 1 lr = lr + 1 Wend End If i = i + 1 Wend End With End Sub
[/vba] Второй [vba]
Код
Sub Мяв() Dim arr, lr&, i&, k& lr = Cells(Rows.Count, "A").End(xlUp).Row arr = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp)).Resize(, 2).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) .Item(arr(i, 1)) = 1 Next For i = lr To 2 Step -1 If Not .exists(Cells(i, "A").Value) Then Cells(i, "A").Resize(, 2).Delete Shift:=xlUp End If Next lr = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To lr k = i While Cells(k, "A") <> Cells(k, "D") Cells(k, "A").Resize(, 2).Insert Shift:=xlDown k = k + 1 Wend Next End With End Sub
[/vba] Кто нужнее?
На первый-второй рассчитайся! Первый [vba]
Код
Sub Мяу() Dim arr, lr&, i&, k& lr = Cells(Rows.Count, "A").End(xlUp).Row arr = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp)).Resize(, 2).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) .Item(arr(i, 1)) = 1 Next lr = Cells(Rows.Count, "A").End(xlUp).Row i = 2 While i <= lr If Not .exists(Cells(i, "A").Value) Then Cells(i, "D").Resize(, 2).Insert Shift:=xlDown Else k = i While Cells(k, "A") <> Cells(k, "D") Cells(k, "A").Resize(, 2).Insert Shift:=xlDown k = k + 1 lr = lr + 1 Wend End If i = i + 1 Wend End With End Sub
[/vba] Второй [vba]
Код
Sub Мяв() Dim arr, lr&, i&, k& lr = Cells(Rows.Count, "A").End(xlUp).Row arr = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp)).Resize(, 2).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) .Item(arr(i, 1)) = 1 Next For i = lr To 2 Step -1 If Not .exists(Cells(i, "A").Value) Then Cells(i, "A").Resize(, 2).Delete Shift:=xlUp End If Next lr = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To lr k = i While Cells(k, "A") <> Cells(k, "D") Cells(k, "A").Resize(, 2).Insert Shift:=xlDown k = k + 1 Wend Next End With End Sub
прикрепил файл 888.xls это по первому варианту. Данных в файле было около 2000 строк, может из-за большого массива он так выполняется? а второй вариант не могу прикрепить, потому что ставлю на выполнение макроса и в итоге он зависает!
прикрепил файл 888.xls это по первому варианту. Данных в файле было около 2000 строк, может из-за большого массива он так выполняется? а второй вариант не могу прикрепить, потому что ставлю на выполнение макроса и в итоге он зависает!rayzer
В первом макросе 1 строчку поменять, 1 добавить для скорости [vba]
Код
Sub Мяу() Dim arr, lr&, i&, k& lr = Cells(Rows.Count, "A").End(xlUp).Row arr = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp)).Resize(, 2).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr)
.Item(arr(i, 1)) = 1 Next Application.ScreenUpdating = False lr = Cells(Rows.Count, "A").End(xlUp).Row i = 2 While i <= lr If Not .exists(Cells(i, "A").Value) Then Cells(i, "D").Resize(, 2).Insert Shift:=xlDown Else k = i While Cells(k, "A") <> Cells(k, "D") Cells(k, "A").Resize(, 2).Insert Shift:=xlDown k = k + 1 lr = lr + 1 Wend End If i = IIf(i > k, i + 1, k + 1) Wend End With End Sub
[/vba] Второй макрос с такими данными работать и не должен, ибо расчитан на то, что 3 квартал - накопительный по отношению ко 2.
В первом макросе 1 строчку поменять, 1 добавить для скорости [vba]
Код
Sub Мяу() Dim arr, lr&, i&, k& lr = Cells(Rows.Count, "A").End(xlUp).Row arr = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp)).Resize(, 2).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr)
.Item(arr(i, 1)) = 1 Next Application.ScreenUpdating = False lr = Cells(Rows.Count, "A").End(xlUp).Row i = 2 While i <= lr If Not .exists(Cells(i, "A").Value) Then Cells(i, "D").Resize(, 2).Insert Shift:=xlDown Else k = i While Cells(k, "A") <> Cells(k, "D") Cells(k, "A").Resize(, 2).Insert Shift:=xlDown k = k + 1 lr = lr + 1 Wend End If i = IIf(i > k, i + 1, k + 1) Wend End With End Sub
[/vba] Второй макрос с такими данными работать и не должен, ибо расчитан на то, что 3 квартал - накопительный по отношению ко 2.RAN
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Все работает именно так как надо!!! 
Очень помогли в работе )))
