Страницы: 1 2 След.
RSS
Копирование из книги в другую книгу без дублей
 
добрый вечер на форуме !

Есть проблема не знаю как с ней справится  тк чайник в 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
Изменено: Vitor - 17.06.2018 22:04:58
 
Vitor, написАл
Цитата
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
Обе книги должны быть открыты. По вопросу дублей пока не думал
 
Цитата
Kuzmich написал:
По вопросу дублей пока не думал
Не очень - то понятно про дубли - как, откуда и какие из элементов записей подлежат удалению, но...
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")  но что это и как применить не знаю ..
Изменено: Vitor - 18.06.2018 08:59:32
 
полазил по инету нашел код который работает -удаляет повторяющиеся строки  снизу - но только в рамках активного листа сравнивает значения снизу по столбцу 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

Изменено: Vitor - 18.06.2018 10:52:36
 
Цитата
Еще повозился  - добавил дату выгрузки в столбец 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. Удачи!
 
Цитата
Vitor написал: но что это и как применить не знаю ..
Описание объекта Dictionary
Согласие есть продукт при полном непротивлении сторон
 
блин ну и задачи   могу только с примеров посмотреть
вот шаг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

сделал так - это правильно или нет ?
Изменено: Vitor - 18.06.2018 11:39:39
 
Код
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 ' если значения нет  ?
Изменено: Vitor - 20.06.2018 01:09:05
 
Цитата
Как правильно то сделать ?
Код
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
 
Kuzmich огромная вам благодарность за поддержку ! Работает проверил   на всякий случай оба файла с макросами выложил
 
блин ну так все было хорошо
просмотрел - в дальнейшем вылез один косяк при копировании из книги Главная в Книга2

Если самая Нижняя строка Книга2 заполнена не полностью а частично
Тогда при копированнии из книги Главная в Книга2
копирование построчно не получается
В пустые диапазоны нижней строки Книга2 при копировании залезает часть диапазона
из книги Главная  - как это побороть ?

Пример с описанием этого приложил
Изменено: Vitor - 20.06.2018 10:07:38
 
Цитата
Vitor написал:
как это побороть ?
- не нужно вычислять индивидуально
Код
LastRow2 = .Cells(.Rows.Count, arr2(j)).End(xlUp).Row

определите один раз для всей строки и используйте.
Тем более что вроде уже и определили выше:
Код
n = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

только не понял зачем это делаете многократно в цикле...
Да и копировать вероятно удобнее сразу всю строку, а не по одной ячейке в цикле. Ну впрочем не вникал, какой-то путаный код...
Изменено: Hugo - 20.06.2018 10:28:43
 
Hugo, Игорь там разный порядок столбцов в книгах, поэтому копировал по одной ячейке в цикле
 
Критерий по которому определяется дубль данных какой? т.е. по каким столбцам должно быть совпадение что бы считаться дублем? в файле книга2.
"Все гениальное просто, а все простое гениально!!!"
 
Вот так скорректировал - изменения минимальны, внедрил одну строку, отключил четыре:
Код
    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)) - тут возможна ошибка, но на примере работает.
Но можно и в цикле, но по уже определённой строке!
 
сейчас как надо работает - Hugo спасибо Вам за помощь !
 
Код для удаления дублей в файле книга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
Изменено: Nordheim - 20.06.2018 11:05:23
"Все гениальное просто, а все простое гениально!!!"
 
спасибо всем кто откликнулся ! извиняюсь за настойчивость в теме
сейчас код работает но как его заставить работать с фильтрованным диапазоном исходной книги Главная лист для Экспорта
фильтрованный диапазон вставил в середину кода - но последующая строка
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

Изменено: Vitor - 20.06.2018 20:13:46
 
Нужно сперва проверить строку на видимость.
Вот тут добавил одну проверку (две строки, 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
Изменено: Hugo - 20.06.2018 20:23:25
 
почитал в инете
.SpecialCells(xlCellTypeVisible)  так на видимость проверяется  и сделать так ?
Код
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)).SpecialCells(xlCellTypeVisible).Copy .Cells(n, 1)
 
Ну можно цикл по видимым, но проще как я выше код поправил.
 
А нет, чуть не так - Вы там диапазон сдвинули, ну подправьте чтоб позиции проверяемой и копируемой строки совпадали!
P.S. Сам нащупал:
Код
If Rows(i + 2).Hidden = False Then
Изменено: Hugo - 20.06.2018 20:28:37
 
сделал выше вставил код ваш - - вставляет правильно но проверка по другим листам на дубли пропала - дубли с других листов залазят в выгрузку
сейчас примеры
Изменено: Vitor - 20.06.2018 20:30:23
 
вставил вашу последнюю поправку в код - все заработало как надо !
Hugo - большое спасибо за поддержку !
Изменено: Vitor - 20.06.2018 20:41:24
 
не получается опять (рано радовался)- прошла полночь и предыдущий вариант перестал работать (видимо завтрашний день сменился и в автофильтре вылезли другие ячейки уже - и с ними предыдущие примеры не сработали)    Сделал все идентично по обоим таблицам - по 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
           
Изменено: Vitor - 21.06.2018 00:34:46
 
так тоже полностью не получилось- дубли то отсеиваются но почемуто 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
Изменено: Vitor - 21.06.2018 08:30:47
 
Попробуйте такой код.
Код
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
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1 2 След.
Наверх