Страницы: 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 - 05.06.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 - 05.06.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 - 09.06.2018 08:09:08
"Все гениальное просто, а все простое гениально!!!"
 
Сейчас работает без ошибок Nordheim - спасибо !  только одно можете посоветовать - как вырезать-вставить из ТаблицаКО2.xls (а не просто скопировать) данные ?
 
Цитата
igrek2 написал:
как вырезать-вставить из ТаблицаКО2.xls (а не просто скопировать) данные ?
Для чего это нужно? В коде совсем другой принцип, тут ничего не копируется и не вырезается.
Изменено: Nordheim - 07.06.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 - 08.06.2018 19:41:05
 
Цитата
igrek2 написал:
тупо не могу вставить delete
Обработка идет в массиве а не на листе поэтому Delete, нет возможности вставить.
Изменено: Nordheim - 09.06.2018 08:10:46
"Все гениальное просто, а все простое гениально!!!"
 
Добрый вечер. Помогите с кодом копирования данных из листа одной книги в лист другой книги пожалуйста? Добавила такой код,он работает, но не совсем так как мне нужно(
Код
Sub ()
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("E:\Ïðîãðàììà\DataBase.dml\Çàÿâêà íà ðåìîíò.xlsm") ' путь где находится книга в которую нужно скопировать данные
wb1.Sheets("Название копируемого листа").Copy Before:=wb2.Sheets(4)
wb1.Save
wb1.Close
wb1.Quit
wb2.Save
wb2.Close
wb2.Quit
End Sub
Данный код каждый раз добавляет новую копию на место листа № 4( А мне необходимо, что бы этот лист он обновлял/заменял. И еще вопросик, можно ли к этому коду привязать не весь лист, а копировать только диапазон A3:D и обязательно ли открывать книгу в которую будут копироваться данные?
 
Цитата
Kcuxa_xa написал:
обязательно ли открывать книгу в которую будут копироваться данные?
Да, но можно обратиться через GetObject. В этом случае открытая книга не будет видна на экране.
Скрытый текст

Намеренно не стал закрывать файл с макросом. Что бы все отработало нормально
Изменено: Nordheim - 17.01.2019 22:37:33
"Все гениальное просто, а все простое гениально!!!"
 
Выдает ошибку "run-time error '1004' Allocation-defined or object-defined error" на 6 строчке(
новые листы уже не создает, но информацию не переносит.
Изменено: Kcuxa_xa - 17.01.2019 22:56:17
 
А так?
Код
wb1.Sheets("Название копируемого листа").Range("a3:d" & Rows.Count).Copy wb2.Sheets(4).Range("a3")
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
А так?
Да так все отлично работает) Благодарю Вас) Nordheim а форму с макросом вы говорили лучше не закрывать? Просто код изначально был прикреплен к кнопке закрыть файл, что бы при закрытии он обновлял информаци в другом. Но лучше выход сделать отдельно?
Изменено: Kcuxa_xa - 18.01.2019 07:53:10
 
Цитата
Kcuxa_xa написал:форму с макросом вы говорили лучше не закрывать
Т.к. у меня все макросы находятся в настройке, то две обрабатываемые книги  я бы закрыл, но ни в одной из них не было бы макросов, а так предпочитаю не закрывать файл , который содержит работающую процедуру. Но если Вам необходимо закрывать файл, то  перед
Скрытый текст
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Наверх