Есть проблема не знаю как с ней справится тк чайник в VBA
Есть две книги - Главная.xlsm и Книга2.xlsm диапазон Главная.xlsm A4:T диапазон Книга2.xlsm A4:J Из главной Главная.xlsm с листа "Для_экспорта" в Книга2.xlsm лист "Для_получения" копируются данные по условиям заполнения после последней заполненной строки
из Главная.xlsm.Лист "Для_экспорта" столбец 1 в Книга2.xlsm лист "Для_получения" столбец 1 из Главная.xlsm.Лист "Для_экспорта" столбец 2 в Книга2.xlsm лист "Для_получения" столбец 2 из Главная.xlsm.Лист "Для_экспорта" столбец 5 в Книга2.xlsm лист "Для_получения" столбец 3 из Главная.xlsm.Лист "Для_экспорта" столбец 7 в Книга2.xlsm лист "Для_получения" столбец 5 из Главная.xlsm.Лист "Для_экспорта" столбец 10 в Книга2.xlsm лист "Для_получения" столбец 6 из Главная.xlsm.Лист "Для_экспорта" столбец 14 в Книга2.xlsm лист "Для_получения" столбец 7 из Главная.xlsm.Лист "Для_экспорта" столбец 15 в Книга2.xlsm лист "Для_получения" столбец 8
C этой задачей вроде как справился (макрос как мог сделал 3 этажный путем переноса по столбцам - надо по строкам вроде но не знаю как) но одно но - при экспорте данных надо исключить дубли для копируемой строки - не знаю как это сделать дубль распознается как значение столбца В из Главная.xlsm.Лист "Для_экспорта" - если этот дубль есть на любых листах Книга2.xlsm (в Книга2.xlsm три листа)
Файлы примера во вложении
Код
Sub Экспорт_в_Книга2()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim LastRow1&, LastRow2&, Rngl As Range, Rng2 As Range
Set sht1 = Workbooks("Главная.xlsm").Worksheets("Для_экспорта")
Set sht2 = Workbooks("Книга2.xlsm").Worksheets("Для_получения")
LastRow1 = sht1.Range("b" & sht1.Rows.Count).End(xlUp).Row
LastRow2 = sht2.Range("h" & sht2.Rows.Count).End(xlUp).Row
Set Rngl = Workbooks("Главная.xlsm").Sheets("Для_экспорта").Range(Cells(4, 1), Cells(LastRow1, 1))
Workbooks("Книга2.xlsm").Worksheets("Для_получения").Activate
Set Rng2 = Workbooks("Книга2.xlsm").Sheets("Для_получения").Range(Cells(LastRow2 + 1, 1), Cells(LastRow2 + 500, 1))
Rngl.Copy Rng2
Workbooks("Главная.xlsm").Worksheets("Для_экспорта").Activate
Set Rng1 = Workbooks("Главная.xlsm").Sheets("Для_экспорта").Range(Cells(4, 2), Cells(LastRow1, 2))
Workbooks("Книга2.xlsm").Worksheets("Для_получения").Activate
Set Rng2 = Workbooks("Книга2.xlsm").Sheets("Для_получения").Range(Cells(LastRow2 + 1, 2), Cells(LastRow2 + 500, 2))
Rng1.Copy Rng2
Workbooks("Главная.xlsm").Worksheets("Для_экспорта").Activate
Set Rng1 = Workbooks("Главная.xlsm").Sheets("Для_экспорта").Range(Cells(4, 5), Cells(LastRow1, 5))
Workbooks("Книга2.xlsm").Worksheets("Для_получения").Activate
Set Rng2 = Workbooks("Книга2.xlsm").Sheets("Для_получения").Range(Cells(LastRow2 + 1, 3), Cells(LastRow2 + 500, 3))
Rng1.Copy Rng2
'и так далее
End Sub
C этой задачей вроде как справился (макрос как мог сделал 3 этажный путем переноса по столбцам
Эту задачу можно решить так
Код
Sub Экспорт_в_Книга2_()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim LastRow1&, LastRow2&, i&
Dim arr1, arr2
Set sht1 = Workbooks("Главная.xls").Worksheets("Для_экспорта")
Set sht2 = Workbooks("Книга2.xls").Worksheets("Для_получения")
LastRow1 = Cells(Rows.Count, "B").End(xlUp).Row
arr1 = Array(1, 2, 5, 7, 10, 14, 15)
arr2 = Array(1, 2, 4, 5, 6, 7, 8)
With sht2
For i = 0 To UBound(arr1)
LastRow2 = .Cells(.Rows.Count, arr2(i)).End(xlUp).Row
Range(Cells(4, arr1(i)), Cells(LastRow1, arr1(i))).Copy .Cells(LastRow2 + 1, arr2(i))
Next
End With
End Sub
Обе книги должны быть открыты. По вопросу дублей пока не думал
Не очень - то понятно про дубли - как, откуда и какие из элементов записей подлежат удалению, но... usedrange.select и replase наверное автору в помощь В replase подставлять в качестве элемента замены пустую строку. Тогда лишнее будет заменяться на пустоту, т.е удаляться из всего, где попадается.
Kuzmich ваш код моментально переносит столбцы - благодарю! Еще повозился - добавил дату выгрузки в столбец 3 Книга2.xls
Код
Sub Экспорт_в_Книга2_()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim LastRow1&, LastRow2&, LastRow2c&, LastRow2b&, i&
Dim arr1, arr2
Set sht1 = Workbooks("Главная.xlsm").Worksheets("Для_экспорта")
Set sht2 = Workbooks("Книга2.xlsm").Worksheets("Для_получения")
LastRow1 = Cells(Rows.Count, "B").End(xlUp).Row
arr1 = Array(1, 2, 5, 7, 10, 14, 15)
arr2 = Array(1, 2, 4, 5, 6, 7, 8)
With sht2
For i = 0 To UBound(arr1)
LastRow2 = .Cells(.Rows.Count, arr2(i)).End(xlUp).Row
Range(Cells(4, arr1(i)), Cells(LastRow1, arr1(i))).Copy .Cells(LastRow2 + 1, arr2(i))
Next
Workbooks("Книга2.xlsm").Worksheets("Для_получения").Activate
LastRow2c = Cells(Rows.Count, "C").End(xlUp).Row
LastRow2b = Cells(Rows.Count, "B").End(xlUp).Row
For i = LastRow2c + 1 To LastRow2b
Range(Cells(i, 3), Cells(i, 3)) = Format(Now, "dd.mm.yyyy")
Next
End With
End Sub
Но к сожалению это не решает проблему дублей с Книга2.xls - тк могут быть дубли (на всех листах Книга2.xlsm -у книги Книга2.xlsm три листа "Для получения","Лист2","Лист3") + еще при вторичном нажатии кнопки диапазон опять перенесется в Книга2.xlsm "Для_получения"(тоже опять дубли получаются). Дубли определяются по значению как значение столбца В из Главная.xlsm.Лист "Для_экспорта" при переносе(копировании) из Главная.xlsm в Книга2.xls и видимо надо както сравнивать в Книга2 "Для_получения" полученное значение при копировании с другими значениями на этом листе и других листах Книга2 "Лист1" "Лист2" - если оно совпадает то - из полученного строка удаляется. PS: смотрю примеры и понимаю что ничего не понимаю - в примерах для поиска дублей используется Set dic = CreateObject("Scripting.Dictionary") но что это и как применить не знаю ..
полазил по инету нашел код который работает -удаляет повторяющиеся строки снизу - но только в рамках активного листа сравнивает значения снизу по столбцу 2 диапазон с 4 строки как его переделать чтоб сравнивал на активном листе"Для_получения" также с значениями в листах "Лист1","Лист2"
Код
Sub УдалениеПовторяющихсяСтрок()
Dim Start As Long, Finish As Long
Start = 4: col = 2
'Application.ScreenUpdating = False
With ActiveSheet.Cells(ActiveSheet.Rows.Count, col).End(xlUp).Row
Finish = ActiveSheet.Cells(ActiveSheet.Rows.Count, col).End(xlUp).Row
Set Rng = ActiveSheet.Range(ActiveSheet.Cells(Start, col), ActiveSheet.Cells(Finish, col))
For i = Finish To Start Step -1
If Application.CountIf(Rng, Cells(i, col)) > 1 Then Rows(i).Delete
Next i
End With
'Application.ScreenUpdating = True
End Sub
Еще повозился - добавил дату выгрузки в столбец 3 Книга2.xls
Вам нужно обратить внимание на конструкцию With ..... End With
Код
With sht2
n = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
For i = 0 To UBound(arr1)
LastRow2 = .Cells(.Rows.Count, arr2(i)).End(xlUp).Row
Range(Cells(4, arr1(i)), Cells(LastRow1, arr1(i))).Copy .Cells(LastRow2 + 1, arr2(i))
Next
.Cells(n, "C").Resize(LastRow1 - 3) = Format(Now, "dd.mm.yyyy")
End With
Цитата
в примерах для поиска дублей используется Set dic = CreateObject("Scripting.Dictionary") но что это и как применить не знаю ..
Нужно сделать цикл по листам Книга2 и собрать в словарь уникальные номера из столбца В. Затем уже цикл по строкам книги Главная с проверкой номера на вхождение в словарь, если номер есть, то строку не переносить в Книгу2. Удачи!
блин ну и задачи могу только с примеров посмотреть вот шаг1
Цитата
Kuzmich написал: Нужно сделать цикл по листам Книга2 и собрать в словарь уникальные номера из столбца В.
Код
'Цикл по листам книги Книга2.xlsm - собрать в словарь все данные заполн столбцов B на всех листах
Set sht2 = Workbooks("Книга2.xlsm").Worksheets("Для_получения")
sht2.Activate
Dim dic As Object, Rng2(), j&
Set dic = CreateObject("Scripting.Dictionary")
Dim Wsh As Worksheet
For Each Wsh In ThisWorkbook.Worksheets
If Wsh.Name = "Для_получения" Or Wsh.Name = "Лист1" Or Wsh.Name = "Лист2" Then
LastRow2b = Wsh.Cells(Wsh.Rows.Count, "B").End(xlUp).Row
Rng2 = Wsh.[a4].Resize(LastRow2b - 3, 10).Value
For j = 1 To UBound(Rng2)
dic.Item(CStr(Rng2(j, 2))) = 0
Next j
End If
Dim Wbk2 As Workbook
'Цикл по листам книги Книга2.xlsm - собрать в словарь все данные заполн столбцов B на всех листах
Set Wbk2 = Workbooks("Книга2.xls")
Dim dic As Object, Rng2(), j&
Set dic = CreateObject("Scripting.Dictionary")
Dim Wsh As Worksheet
For Each Wsh In Wbk2.Worksheets
Wsh.Activate
LastRow2b = Wsh.Cells(Wsh.Rows.Count, "B").End(xlUp).Row
For j = 4 To LastRow2b
dic.Item(CStr(Cells(j, 2))) = 0
Next j
Next
Целый день вчера разбирался чтоб понять словарь но так токо все приблизительно понял получилось так
Код
Sub НомераB_в_Словарь()
'Нужно сделать цикл по листам Книга2 и собрать в словарь уникальные номера из столбца В.
'Затем уже цикл по строкам книги Главная с проверкой номера на вхождение в словарь,
'если номер есть, то строку не переносить в Книгу2. Удачи!
Dim Wbk2 As Workbook
'Цикл по листам книги Книга2.xlsm - собрать в словарь все данные заполн столбцов B на всех листах Книга2
Set Wbk2 = Workbooks("Книга2.xlsm")
Dim dic As Object, Rng2(), j&, i&
Set dic = CreateObject("Scripting.Dictionary")
Dim Wsh As Worksheet
For Each Wsh In Wbk2.Worksheets
Wsh.Activate
LastRow2b = Wsh.Cells(Wsh.Rows.Count, "B").End(xlUp).Row
For j = 4 To LastRow2b
dic.Item(CStr(Cells(j, 2))) = 0
Next j
Next
'Затем уже собираем значения B на листе1 книги Главная
Dim Wbk1 As Workbook
Set Wbk1 = Workbooks("Главная.xlsm").Worksheets(1)
Wbk1.Activate 'активируем лист Главная
LastRow1b = Wbk1.Cells(Wbk1.Rows.Count, "B").End(xlUp).Row
For i = 4 To LastRow1b
' передаем в словарь все данные заполн столбцов B на всех листах Главная и сравниваем со значениями Книга2
' если значения нет
If Not dic.Exists(CStr(larr(i, 2))) Then
'КАК СЮДА МАКРОС Экспорт_в_Книга2 по строкам вставить - как его связать по этим условиям ? и правильно ли условие сделал?
End If
Next i
End Sub
Sub Экспорт_в_Книга2()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim LastRow1&, LastRow2&, LastRow22&, LastRow33&, i&
Dim arr1, arr2
Set sht1 = Workbooks("Главная.xlsm").Worksheets("Для_экспорта")
Set sht2 = Workbooks("Книга2.xlsm").Worksheets("Для_получения")
LastRow1 = Cells(Rows.Count, "B").End(xlUp).Row
arr1 = Array(1, 2, 5, 7, 10, 14, 15)
arr2 = Array(1, 2, 4, 5, 6, 7, 8)
With sht2
n = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
For i = 0 To UBound(arr1)
LastRow2 = .Cells(.Rows.Count, arr2(i)).End(xlUp).Row
Range(Cells(4, arr1(i)), Cells(LastRow1, arr1(i))).Copy .Cells(LastRow2 + 1, arr2(i))
Next
.Cells(n, "C").Resize(LastRow1 - 3) = Format(Now, "dd.mm.yyyy")
.Cells(n, "C").Resize(LastRow1 - 3).NumberFormat = "m/d/yyyy"
End With
End Sub
Остались вопросы - как в это условие макрос Сall Экспорт_в_Книга2 вставить - как его связать то с условием ? и правильно ли условие сделал ' передаем в словарь все данные заполн столбцов B на всех листах Главная и сравниваем со значениями Книга2 ' если значения нет ?
Sub Экспорт_в_Книга2_()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim LastRow1&, LastRow2&, i&, j&, n&
Dim arr1, arr2
Dim Wbk2 As Workbook
Dim dic As Object
Set sht1 = Workbooks("Главная.xls").Worksheets("Для_экспорта")
Set sht2 = Workbooks("Книга2.xls").Worksheets("Для_получения")
'Цикл по листам книги Книга2.xlsm - собрать в словарь все данные заполн столбцов B на всех листах
Set Wbk2 = Workbooks("Книга2.xls")
Set dic = CreateObject("Scripting.Dictionary")
Dim Wsh As Worksheet
For Each Wsh In Wbk2.Worksheets 'цикл по всем листам Книги2
Wsh.Activate
LastRow2b = Wsh.Cells(Wsh.Rows.Count, "B").End(xlUp).Row
For j = 4 To LastRow2b 'заполняем словарь уникальными номерами
dic.Item(CStr(Cells(j, 2))) = 0
Next j
Next
sht1.Activate
LastRow1 = Cells(Rows.Count, "B").End(xlUp).Row
arr1 = Array(1, 2, 5, 7, 10, 14, 15)
arr2 = Array(1, 2, 4, 5, 6, 7, 8)
With sht2
For i = 4 To LastRow1
If Not dic.exists(Cells(i, 2).Value) Then 'есть ли номер в словаре
dic.Add Cells(i, 2).Value, 0 'если нет, то добавляем
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
For j = 0 To UBound(arr1)
LastRow2 = .Cells(.Rows.Count, arr2(j)).End(xlUp).Row
Cells(i, arr1(j)).Copy .Cells(LastRow2 + 1, arr2(j))
Next
.Cells(n, "C") = Format(Now, "dd.mm.yyyy")
End If
Next
End With
End Sub
блин ну так все было хорошо просмотрел - в дальнейшем вылез один косяк при копировании из книги Главная в Книга2
Если самая Нижняя строка Книга2 заполнена не полностью а частично Тогда при копированнии из книги Главная в Книга2 копирование построчно не получается В пустые диапазоны нижней строки Книга2 при копировании залезает часть диапазона из книги Главная - как это побороть ?
определите один раз для всей строки и используйте. Тем более что вроде уже и определили выше:
Код
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
только не понял зачем это делаете многократно в цикле... Да и копировать вероятно удобнее сразу всю строку, а не по одной ячейке в цикле. Ну впрочем не вникал, какой-то путаный код...
Вот так скорректировал - изменения минимальны, внедрил одну строку, отключил четыре:
Код
With sht2
For i = 4 To LastRow1
If Not dic.exists(Cells(i, 2).Value) Then 'есть ли номер в словаре
dic.Add Cells(i, 2).Value, 0 'если нет, то добавляем
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Union(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 5), Cells(i, 7), Cells(i, 10), Cells(i, 14), Cells(i, 15)).Copy .Cells(n, 1)
' For j = 0 To UBound(arr1)
' LastRow2 = .Cells(.Rows.Count, arr2(j)).End(xlUp).Row
' Cells(i, arr1(j)).Copy .Cells(LastRow2 + 1, arr2(j))
' Next
.Cells(n, "C") = Format(Now, "dd.mm.yyyy")
.Cells(n, "C").NumberFormat = "m/d/yyyy"
End If
Next
End With
Kuzmich написал: там разный порядок столбцов в книгах, поэтому копировал по одной ячейке в цикле
не разный, а с "дырами"! Одну отсутствующую просто заткнул пустой ячейкой (Cells(i, 3)) - тут возможна ошибка, но на примере работает. Но можно и в цикле, но по уже определённой строке!
Код для удаления дублей в файле книга2. Критерий совпадения столбцы с 2 по 7.
Код
Sub iRemoveDuplicate()
Dim sht As Worksheet, arr(), i&, j&, txt$, x&
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Set sht = Worksheets("Для_получения")
With sht
i = .Range("a" & .Rows.Count).End(xlUp).Row - 3
j = .Cells(4, .Columns.Count).End(xlToLeft).Column
arr = .[a4].Resize(i, j).Value
.Range("a4").Resize(i, j).ClearContents
For i = 1 To UBound(arr)
txt = ""
For j = 2 To UBound(arr, 2)
txt = txt & arr(i, j)
Next j
If Not dic.Exists(txt) Then
dic.Item(txt) = 0
x = x + 1
arr(x, 1) = x
For j = 2 To UBound(arr, 2)
arr(x, j) = arr(i, j)
Next j
End If
Next i
.[a4].Resize(x, UBound(arr, 2)).Value = arr
End With
End Sub
спасибо всем кто откликнулся ! извиняюсь за настойчивость в теме сейчас код работает но как его заставить работать с фильтрованным диапазоном исходной книги Главная лист для Экспорта фильтрованный диапазон вставил в середину кода - но последующая строка LastRow1 = Cells(Rows.Count, "B").End(xlUp).Row 'задаем диапазоны для экспорта и получения все равно определяет значения без фильтра и в Книга2 все равно падают значения без автофильтра
код такой получился еще примеры приложил
Код
Sub Экспорт_в_Книга2_()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim LastRow1&, LastRow2&, i&, j&, n&
Dim arr1, arr2
Dim x&, LastRow1b As Long, LastRow2b As Long
Dim Wbk2 As Workbook
Dim dic As Object
Set sht1 = Workbooks("Главная.xlsm").Worksheets("Для_экспорта")
Set sht2 = Workbooks("Книга2.xlsm").Worksheets("Для_получения")
'Цикл по листам книги Книга2.xlsm - собрать в словарь все данные заполн столбцов B на всех листах
Set Wbk2 = Workbooks("Книга2.xlsm")
Set dic = CreateObject("Scripting.Dictionary")
Dim Wsh As Worksheet
For Each Wsh In Wbk2.Worksheets 'цикл по всем листам Книги2
Wsh.Activate
LastRow2b = Wsh.Cells(Wsh.Rows.Count, "B").End(xlUp).Row
For j = 4 To LastRow2b 'заполняем словарь уникальными номерами
dic.Item(CStr(Cells(j, 2))) = 0
Next j
Next
sht1.Activate 'активируем лист для экспорта
'вставляем блок автофильтра по датам на завтра по 14 столбцу
LastRow1b = sht1.Range("b" & sht1.Rows.Count).End(xlUp).Row 'делаем автофильтр в рабочем диапазоне
Set Rng1 = sht1.Range(sht1.Cells(3, 1), sht1.Cells(LastRow1b, 20))
Rng1.AutoFilter 14, Criteria1:=xlFilterTomorrow, Operator:=xlFilterDynamic 'автофильтр завтра
x = sht1.AutoFilter.Range.Columns(1).SpecialCells(xlVisible).Count - 1 'если автофмльтр непустой (считаем колво строк автофильтра)
If x > 0 Then
LastRow1 = Cells(Rows.Count, "B").End(xlUp).Row 'задаем диапазоны для экспорта и получения из автофильтра
Set RngAF = sht1.Range(sht1.Cells(3, 1), sht1.Cells(LastRow1, 20)) 'определяем диапазон с автофильтром
'как дальше забрать значения и вставить только из автофильтра ?
arr1 = Array(1, 2, 5, 7, 10, 14, 15)
arr2 = Array(1, 2, 4, 5, 6, 7, 8)
With sht2 'действия с листом для получения значений
For i = 4 To LastRow1
If Not dic.exists(Cells(i, 2).Value) Then 'есть ли номер в словаре
dic.Add Cells(i, 2).Value, 0 'если нет, то добавляем
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Union(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 5), Cells(i, 7), Cells(i, 10), Cells(i, 14), Cells(i, 15)).Copy .Cells(n, 1)
.Cells(n, "C") = Format(Now, "dd.mm.yyyy")
.Cells(n, "C").NumberFormat = "m/d/yyyy"
End If
Next
End With
sht1.Activate
sht1.AutoFilter.ShowAllData 'сброс автофильтра
End If
End Sub
Нужно сперва проверить строку на видимость. Вот тут добавил одну проверку (две строки, 3 и 12):
Код
With sht2 'действия с листом для получения значений
For i = 4 To LastRow1
If Rows(i).Hidden = False Then
If Not dic.exists(Cells(i, 2).Value) Then 'есть ли номер в словаре
dic.Add Cells(i, 2).Value, 0 'если нет, то добавляем
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
'Union(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 5), Cells(i, 7), Cells(i, 10), Cells(i, 14), Cells(i, 15)).Copy .Cells(n, 1)
Union(RngAF.Cells(i, 1), RngAF.Cells(i, 2), RngAF.Cells(i, 3), RngAF.Cells(i, 5), RngAF.Cells(i, 7), RngAF.Cells(i, 10), RngAF.Cells(i, 14), RngAF.Cells(i, 15)).Copy .Cells(n, 1)
.Cells(n, "C") = Format(Now, "dd.mm.yyyy")
.Cells(n, "C").NumberFormat = "m/d/yyyy"
End If
End If
Next
End With
сделал выше вставил код ваш - - вставляет правильно но проверка по другим листам на дубли пропала - дубли с других листов залазят в выгрузку сейчас примеры
не получается опять (рано радовался)- прошла полночь и предыдущий вариант перестал работать (видимо завтрашний день сменился и в автофильтре вылезли другие ячейки уже - и с ними предыдущие примеры не сработали) Сделал все идентично по обоим таблицам - по 3 строки отступа сверху и код первоначальный 3 часа эксперементировал над соотношением 2 параметров - If Rows(i).Hidden = False Then и Union(RngAF.Cells(i, 1), RngAF.Cells(i, 2).... ставил i-1 i+1 - но ничего не добился Щас таблицы идентичные и стоит If Rows(i).Hidden и Union(RngAF.Cells(i, 1), RngAF.Cells(i, 2)... но значения записыватся неправильные Почему ?
Код
With sht2 'действия с листом для получения значений
For i = 4 To LastRow1
If Rows(i).Hidden = False Then
If Not dic.exists(Cells(i, 2).Value) Then 'есть ли номер в словаре
dic.Add Cells(i, 2).Value, 0 'если нет, то добавляем
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
'Union(Cells(i,1), Cells(i, 2), Cells(i, 3), Cells(i, 5), Cells(i, 7), Cells(i, 10), Cells(i, 14), Cells(i, 15)).Copy .Cells(n, 1)
Union(RngAF.Cells(i,1), RngAF.Cells(i, 2), RngAF.Cells(i, 3), RngAF.Cells(i, 5), RngAF.Cells(i, 7), _
RngAF.Cells(i, 10), RngAF.Cells(i, 14), RngAF.Cells(i, 15)).Copy .Cells(n, 1)
.Cells(n, "C") = Format(Now, "dd.mm.yyyy")
.Cells(n, "C").NumberFormat = "m/d/yyyy"
End If
End If
Next
End With
так тоже полностью не получилось- дубли то отсеиваются но почемуто SpecialCells(xlCellTypeVisible) пропускает лишние значения не из фильтра
Код
With sht2 'действия с листом для получения значений
For i = 4 To LastRow1
For Each Cell In RngAF.SpecialCells(xlCellTypeVisible)
'For Each Cell In Range(Cells(i, 1), Cells(LastRow1, 20)).SpecialCells(xlCellTypeVisible)
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If Not dic.exists(Cells(i, 2).Value) Then 'есть ли номер в словаре
dic.Add Cells(i, 2).Value, 0 'если нет, то добавляем
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Union(RngAF.Cells(i - 2, 1), RngAF.Cells(i - 2, 2), RngAF.Cells(i - 2, 3), RngAF.Cells(i - 2, 5), RngAF.Cells(i - 2, 7), RngAF.Cells(i - 2, 10), RngAF.Cells(i - 2, 14), RngAF.Cells(i - 2, 15)).Copy .Cells(n, 1)
.Cells(n, "C") = Format(Now, "dd.mm.yyyy")
.Cells(n, "C").NumberFormat = "m/d/yyyy"
End If
Next
Next
End With
Sub iTranzitData()
Dim arr(), dic As Object
Dim iarr(), j&, txt$, i&, narr(), x&, inum&
Dim sht1 As Worksheet, sht2 As Worksheet
Set dic = CreateObject("Scripting.Dictionary")
Set sht1 = Workbooks("Главная.xlsm").Worksheets("Для_экспорта")
Set sht2 = Workbooks("Книга2.xlsm").Worksheets("Для_получения")
arr = sht1.UsedRange.Value
With sht2
i = .Range("a" & .Rows.Count).End(xlUp).Row - 4
j = .Cells(4, .Columns.Count).End(xlToLeft).Column
iarr = .[a5].Resize(i, j).Value
inum = UBound(iarr)
ReDim larr(1 To UBound(arr), 1 To UBound(iarr, 2))
For i = 1 To UBound(iarr)
txt = iarr(i, 2)
dic.Item(txt) = 0
Next i
narr = Array(2, 1, 5, 7, 10, 14, 15)
j = 0
For i = 4 To UBound(arr)
If Not IsEmpty(arr(i, 2)) Then
If Not dic.Exists(CStr(arr(i, 2))) Then
j = j + 1: inum = inum + 1
For x = 1 To UBound(iarr, 2)
Select Case x
Case 1: larr(j, x) = inum
Case 3: larr(j, x) = Date
Case 8: larr(j, x) = Format(Time, "h:mm")
Case Else: larr(j, x) = arr(i, narr(x - 2))
End Select
Next x
End If
End If
Next i
If j = 0 Then MsgBox "Новых данных нет!!!", vbInformation: Exit Sub
i = .Range("a" & .Rows.Count).End(xlUp).Row + 1
.Range("a" & i).Resize(j, UBound(larr, 2)).Value = larr
End With
End Sub
"Все гениальное просто, а все простое гениально!!!"