Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Перенос данных из листа одной книги в лист другой книги ниже заполненной строки
 
Здравствуйте !

Есть 2 книги: ТаблицаКО.xlsm  и ТаблицаКО2.xls - обе в одной папке
Нужно с ТаблицаКО2.Лист(1)  перенести данные в ТаблицаКО.Лист(1)
Оба листа идентичны по колонкам и переносимому диапазону - надо диапазон A4:F ТаблицаКО2  перенести в A4:F ТаблицаКО

Только вот условия переноса для меня трудные не могу сделать -
перенести надо с дописыванием (ниже последней заполненной строки)
и проверить еще на дубли переносимый диапазон из листа ТаблицаКО2
- если в переносимом диапазоне в строках по столбцу E есть совпадения  со столбцом E куда переносим то эти строки не переносятся - а удаляются просто
те переносятся не дубли

Пока хватило только на то чтобы массивы определить откуда куда переносим - но эти условия не знаю как сделать
Пример на всякий случай приложил с 2 файлами
Код
Sub test()
Dim sht As Worksheet, sht1 As Worksheet
Dim arr(), arr1(), i&, j&, x&
Set sht = Workbooks("ТаблицаKO.xlsm").Sheets(1)
Set sht1 = Workbooks("Новая_выгрузка.xls").Sheets(1)
With sht
    i = .Cells(.Rows.Count, "b").End(xlUp).Row
    'j = .Cells(3, .Columns.Count).End(xlToLeft).Column
    arr = .Range(.Cells(4, "a"), .Cells(i, 6))
End With
With sht1
    i = .Cells(.Rows.Count, "b").End(xlUp).Row
    'j = .Cells(3, .Columns.Count).End(xlToLeft).Column
    arr1 = .Range(.Cells(4, "a"), .Cells(i, 6))
For i = LBound(arr1) To UBound(arr1)

 'както надо перенести здесь

Next i
End With
End Sub
 
Обе книги ТаблицаКО.xls и ТаблицаКО2.xls должны быть открыты
Код
Sub test()
Dim sht As Worksheet, sht1 As Worksheet
Dim i&, iLastRow&, iLastRow2&
Dim Dic As Object
'Set sht = Workbooks("ТаблицаKO.xlsm").Sheets(1)
Set sht = Workbooks("ТаблицаКО.xls").Worksheets("Таблица")
Set sht1 = Workbooks("ТаблицаКО2.xls").Worksheets("Таблица")
    iLastRow = Cells(Rows.Count, "b").End(xlUp).Row
 Set Dic = CreateObject("scripting.dictionary"): Dic.comparemode = 1
   For i = 4 To iLastRow                   'заполняем словарь из столбца Е ТаблицыКО
     If Not Dic.exists(Cells(i, 5).Value) Then   'если нет слова, то добавляем его в словарь
       Dic.Add Cells(i, 5).Value, 1
     End If
   Next
With sht1
    iLastRow2 = .Cells(.Rows.Count, "b").End(xlUp).Row
  For i = 4 To iLastRow2
    iLastRow = Cells(Rows.Count, "b").End(xlUp).Row + 1
     If Not Dic.exists(.Cells(i, 5).Value) Then   'если нет слова, то добавляем его в словарь
       Dic.Add .Cells(i, 5).Value, 1
       .Range("A" & i & ":F" & i).Copy Range("A" & iLastRow)
     End If
  Next
End With
End Sub
 
Спасибо Kuzmich за ваш код ! Он работает  только изменил  немного - надо было вырезать и вставить
Изменил строчки
Код
.Range("A" & i & ":F" & i).Copy Range("A" & iLastRow)
на строчку
Код
.Range("A" & i & ":F" & i).Copy Range("A" & iLastRow)
.Range("A" & i & ":F" & i).ClearContents

Еще одно пожелание - не знаю как сделать   Как вставить только значения в ТаблицаКО.xls ?
попробовал изменить код
Код
Range("A" & i & ":F" & i).Copy 
Range("A" & iLastRow).PasteSpecial Paste:=xlPasteValues
Range("A" & i & ":F" & i).ClearContents
 
но ничего не получилось - значения не вставляются ?  как правильно сделать для вставки только значений (чтоб форматирование не трогать)?
 
Вариант на массивах.
Код
Sub test()
    Dim isht As Worksheet, lsht As Worksheet
    Dim i&, iLastRow&, lLastRow&, j&, k&
    Dim Dic As Object, iarr(), larr()
    Set isht = Workbooks("ТаблицаКО.xlsm").Worksheets(1)
    Set lsht = Workbooks("ТаблицаКО2.xls").Worksheets(1)
    lLastRow = lsht.Range("a" & lsht.Rows.Count).End(xlUp).Row
    iLastRow = isht.Range("a" & isht.Rows.Count).End(xlUp).Row
    larr = lsht.[a4].Resize(lLastRow - 3, 6).Value
    iarr = isht.[a4].Resize(iLastRow - 3, 6).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(iarr)
        Dic.Item(CStr(iarr(i, 5))) = 0
    Next i
    For i = 1 To UBound(larr)
        If Not Dic.exists(CStr(larr(i, 5))) Then
            k = k + 1
            For j = 1 To UBound(iarr, 2)
                larr(k, j) = larr(i, j)
            Next j
        End If
    Next i
    isht.Range("a" & iLastRow + 1).Resize(k, 6).Value = larr
End Sub
Изменено: Nordheim - 5 Июн 2018 08:40:53
"Все гениальное просто, а все простое гениально!!!"
 
в коде Nordheim вашем почемуто ошибка вылазит такая Run-time error 1004   Application-defined or object--defined error на строке
Код
larr = lsht.[a4].Resize(lLastRow - 3, 6).Value
    iarr = isht.[a4].Resize(iLastRow - 3, 6).Value
Изменено: igrek2 - 5 Июн 2018 09:15:02
 
Файлы идентичны тем которые в примере?
"Все гениальное просто, а все простое гениально!!!"
 
igrek2, посмотрите на Workbooks("ТаблицаКО2.xls").Worksheets(1). У Вас там точно больше трёх строк?
 
Код
Sub test()
    Dim isht As Worksheet, lsht As Worksheet
    Dim i&, iLastRow&, lLastRow&, j&, k&
    Dim Dic As Object, iarr(), larr()
    Set isht = Workbooks("ТаблицаКО.xlsm").Worksheets(1)
    Set lsht = Workbooks("ТаблицаКО2.xls").Worksheets(1)
    lLastRow = lsht.Range("a" & lsht.Rows.Count).End(xlUp).Row
    iLastRow = isht.Range("a" & isht.Rows.Count).End(xlUp).Row
    larr = lsht.[a4].Resize(lLastRow - 3, 6).Value
    If lLastRow <=3 Then MsgBox "Исходный массив пустой!": Exit Sub
    If iLastRow = 3 Then isht.[a4].Resize(UBound(larr), 6).Value = larr: Exit Sub
    iarr = isht.[a4].Resize(iLastRow - 3, 6).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(iarr)
        Dic.Item(CStr(iarr(i, 5))) = 0
    Next i
    For i = 1 To UBound(larr)
        If Not Dic.exists(CStr(larr(i, 5))) Then
            k = k + 1
            For j = 1 To UBound(iarr, 2)
                larr(k, j) = larr(i, j)
            Next j
        End If
    Next i
    If k <> 0 Then isht.Range("a" & iLastRow + 1).Resize(k, 6).Value = larr
End Sub


Добавил проверку на заполненость исходного массива!
Изменено: Nordheim - 9 Июн 2018 08:09:08
"Все гениальное просто, а все простое гениально!!!"
 
Сейчас работает без ошибок Nordheim - спасибо !  только одно можете посоветовать - как вырезать-вставить из ТаблицаКО2.xls (а не просто скопировать) данные ?
 
Цитата
igrek2 написал:
как вырезать-вставить из ТаблицаКО2.xls (а не просто скопировать) данные ?
Для чего это нужно? В коде совсем другой принцип, тут ничего не копируется и не вырезается.
Изменено: Nordheim - 7 Июн 2018 19:14:05
"Все гениальное просто, а все простое гениально!!!"
 
для чего нужно - очистить таблицу ТаблицаКО2.xls от перенесенных данных после переноса   (потом в таблицу ТаблицаКО2.xls будут вносится другие данные которые также будут потом перенесены с очисткой ТаблицаКО2.xls)
 
Если реализовать в моем коде, то нужно запускать еще проверку по таблиц ТаблицаКО2.xls  и при совпадении удалять, но проверять нужно только массив larr от первого до
k-того индекса .
"Все гениальное просто, а все простое гениально!!!"
 
вы имеете в виду проверку на дубли по столбцу Е - так дубли же у вас не проходят я проверял все ок   имеется в виду что дубли первого переноса проверяются (и если удаляется массив ТаблицаКО2.xls и вдруг в него попали данные которые совпадают с уже внесенным в  ТаблицаКО.xls - куда переносим то дубли останутся перенесенные ?) ваш код работает быстро и как надо проверил на внесение дублей вторично - не вносятся

Единственные заковыки - это то что когда исходный массив в ТаблицаКО2.xls пустой начиная с 4 строки - тогда ошибка идет на строке larr = lsht.[a4].Resize(lLastRow - 3, 6).Value
и массив не очищается после выгрузки (те сейчас как есть просто копирование с удалением дублей происходит)
но если я както код Kuzmich еще понимаю - то в вашем я ниче совсем понять не могу и тупо не могу вставить delete (куда - еще раз пробегаться до последней строки в конце вашего кода чтоли) - но работает быстрее на более больших заполнениях
поэтому и не знаю как внести измения в ваш код который быстрее - как очистить массив ТаблицаКО2 после выгрузки и исправить ошибку когда вдруг
массив ТаблицаКО2 пустой
Изменено: igrek2 - 8 Июн 2018 19:41:05
 
Цитата
igrek2 написал:
тупо не могу вставить delete
Обработка идет в массиве а не на листе поэтому Delete, нет возможности вставить.
Изменено: Nordheim - 9 Июн 2018 08:10:46
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Читают тему (гостей: 1)