Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Задваивание копируемых данных - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Задваивание копируемых данных (Макросы/Sub)
Задваивание копируемых данных
Olena Дата: Пятница, 12.11.2021, 16:04 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 1 ±
Замечаний: 0% ±

Доброго времени форумчане.
Помогите решить проблему. До этого как то обходилась подстановочкой для своих требований.
Но сегодня столкнулась с этим)
Макрос нашла в теме, решение предложила РElenа, он очень классный, не большой, но я что то делаю не так. У меня он копирует из открытой книги в закрытую, но задваивает значения (затраивание устранила) )
Посмотрите пожалуйста файлик.
К сообщению приложен файл: 1234__.xlsm(22.0 Kb)
 
Ответить
СообщениеДоброго времени форумчане.
Помогите решить проблему. До этого как то обходилась подстановочкой для своих требований.
Но сегодня столкнулась с этим)
Макрос нашла в теме, решение предложила РElenа, он очень классный, не большой, но я что то делаю не так. У меня он копирует из открытой книги в закрытую, но задваивает значения (затраивание устранила) )
Посмотрите пожалуйста файлик.

Автор - Olena
Дата добавления - 12.11.2021 в 16:04
Pelena Дата: Пятница, 12.11.2021, 18:55 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 18117
Репутация: 4059 ±
Замечаний: ±

Excel 2016 & Mac Excel
Я уже писала в личке, что в макросе не предусмотрена проверка на повторы, то есть он просто копирует все строки из одного файла и дописывает к уже имеющимся в другой.
И не совсем понятно, зачем цикл по листам, если лист только один "Сбор", может, поэтому и задваивал?
К сообщению приложен файл: 1234_.xlsm(22.5 Kb)


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеЯ уже писала в личке, что в макросе не предусмотрена проверка на повторы, то есть он просто копирует все строки из одного файла и дописывает к уже имеющимся в другой.
И не совсем понятно, зачем цикл по листам, если лист только один "Сбор", может, поэтому и задваивал?

Автор - Pelena
Дата добавления - 12.11.2021 в 18:55
Olena Дата: Пятница, 12.11.2021, 19:17 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 1 ±
Замечаний: 0% ±

И не совсем понятно, зачем цикл по листам, если лист только один "Сбор", может, поэтому и задваивал?

Может) все верно) спасибо вам большое, я слабо ориентируюсь в этих програмках. Читаю, смотрю, подходит, прикрепляю)
хорошего вам вечера)
 
Ответить
Сообщение
И не совсем понятно, зачем цикл по листам, если лист только один "Сбор", может, поэтому и задваивал?

Может) все верно) спасибо вам большое, я слабо ориентируюсь в этих програмках. Читаю, смотрю, подходит, прикрепляю)
хорошего вам вечера)

Автор - Olena
Дата добавления - 12.11.2021 в 19:17
Olena Дата: Суббота, 13.11.2021, 21:08 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 1 ±
Замечаний: 0% ±

Всем доброго времени.
Подскажите пожалуйста где почитать или образец, хочу сама найти решение.
Решение Елены прекрасно работает, я даже его немного дополнила. Только вот при тестирование поняла, что мне нужна еще одна "функция"
Волнуюсь от случайного не нужного копирования. Вдруг будет "совпадение" а именно, это что-то своего рода архив, и вот вдруг забуду главную таблицу очистить, сработает таймер записи и могу "задублировать" данные.
Подскажите пожалуйста, где бы мне почитать, про сравнение строк перед копирование.
1.Сравнение старых строк вдруг такое будет и они отличаться будут по какому то признаку то перезаписало их.
2. Если они полностью одинаковы - пропустить и дополнило только новыми.
Что я могу уже сделать.
Проверить условие совпадения дат сегодняшняя с последней датой в закрытой книге столбец I [vba]
Код
" If data("dd.mm.yyyy")> Конечная.Sheets("Сбор").Range("I1").CurrentRegion.Rows.Count
[/vba] (могла написать с ошибкой, не проверяла, набросок) так как у меня там даты в основном главный критерий. Этот метод ка по мне не очень красивый и верный.
Хотела бы всю строку проверять, но вот с библиотеками я не умею работать от слова совсем.
Почему прошу дать наводку, а не решить проблему, хочу сама разобраться. Разберусь раз, меньше постов тут создам). Не справлюсь, попрошу помощи :)
Всем хороших выходных)
 
Ответить
СообщениеВсем доброго времени.
Подскажите пожалуйста где почитать или образец, хочу сама найти решение.
Решение Елены прекрасно работает, я даже его немного дополнила. Только вот при тестирование поняла, что мне нужна еще одна "функция"
Волнуюсь от случайного не нужного копирования. Вдруг будет "совпадение" а именно, это что-то своего рода архив, и вот вдруг забуду главную таблицу очистить, сработает таймер записи и могу "задублировать" данные.
Подскажите пожалуйста, где бы мне почитать, про сравнение строк перед копирование.
1.Сравнение старых строк вдруг такое будет и они отличаться будут по какому то признаку то перезаписало их.
2. Если они полностью одинаковы - пропустить и дополнило только новыми.
Что я могу уже сделать.
Проверить условие совпадения дат сегодняшняя с последней датой в закрытой книге столбец I [vba]
Код
" If data("dd.mm.yyyy")> Конечная.Sheets("Сбор").Range("I1").CurrentRegion.Rows.Count
[/vba] (могла написать с ошибкой, не проверяла, набросок) так как у меня там даты в основном главный критерий. Этот метод ка по мне не очень красивый и верный.
Хотела бы всю строку проверять, но вот с библиотеками я не умею работать от слова совсем.
Почему прошу дать наводку, а не решить проблему, хочу сама разобраться. Разберусь раз, меньше постов тут создам). Не справлюсь, попрошу помощи :)
Всем хороших выходных)

Автор - Olena
Дата добавления - 13.11.2021 в 21:08
Olena Дата: Воскресенье, 14.11.2021, 19:05 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 1 ±
Замечаний: 0% ±

Всем добрый вечер.
Поиски не увенчались успехом, ни "подходящего" варианта, ни чего для "легкого ознакомления" не нашла, написано много, только для меня это не подсильна задача <_< Библиотеки, массивы, как его туда "загнать" %)
Видать задачка не из простых)
Может у кого то из форумчан есть относительно готовое решение под мою задачу, я не отказалась бы от помощи)
Всем хорошего вечера)
 
Ответить
СообщениеВсем добрый вечер.
Поиски не увенчались успехом, ни "подходящего" варианта, ни чего для "легкого ознакомления" не нашла, написано много, только для меня это не подсильна задача <_< Библиотеки, массивы, как его туда "загнать" %)
Видать задачка не из простых)
Может у кого то из форумчан есть относительно готовое решение под мою задачу, я не отказалась бы от помощи)
Всем хорошего вечера)

Автор - Olena
Дата добавления - 14.11.2021 в 19:05
Olena Дата: Воскресенье, 14.11.2021, 23:32 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 1 ±
Замечаний: 0% ±

ХМ, нашла подходящий макрос, но вот подправить не могу, так как не знаю, как переписать Открыть файл в сети , прочитать лист, сравнить с листом ( они идентичны по структуре, разные по наполнению) и записать не совпадающие в низ и перезаписать, совпадающие (т.к. иногда будет кое что меняться.)
[vba]
Код
Sub tabsumm()
On Error GoTo какашка
Dim tb1, tb2, rez, wb, f, k, lr(2), strS, strD, str, tr, arr(), nofind(), ActR, temp
wb = ActiveWorkbook.Name
tb1 = "table1"
tb2 = "table2"
rez = "результат"
lr(1) = Workbooks(wb).Sheets(tb1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(2, lr(1))
ReDim nofind(lr(1))
lr(2) = Workbooks(wb).Sheets(tb2).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(wb).Sheets(rez).Cells.Clear
For f = 2 To lr(1)
str = Workbooks(wb).Sheets(tb1).Cells(f, 3).Value
Workbooks(wb).Sheets(tb2).Select
Workbooks(wb).Sheets(tb2).Cells(2, 1).Select
tr = 2
Workbooks(wb).Sheets(tb2).Cells.Find(What:=str, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActR = ActiveCell.Row
If ActR > tr Then
strS = "A" & f & ":C" & f
arr(1, f) = Workbooks(wb).Sheets(tb1).Range(strS).Value
strD = "C" & ActR & ":Q" & ActR
arr(2, f) = Workbooks(wb).Sheets(tb2).Range(strD).Value
nofind(f) = 1
Else
nofind(f) = 0
End If
Next f
f = f - 3
tr = 2
strS = "A1:C1"
strD = "A1:C1"
temp = Workbooks(wb).Sheets(tb1).Range(strS).Value
Workbooks(wb).Sheets(rez).Range(strD).Value = temp
strS = "C1:Q1"
strD = "D1:R1"
temp = Workbooks(wb).Sheets(tb2).Range(strS).Value
Workbooks(wb).Sheets(rez).Range(strD).Value = temp
Workbooks(wb).Sheets(rez).Cells.EntireColumn.AutoFit
Workbooks(wb).Sheets(rez).Cells.WrapText = False

For k = 0 To f
If nofind(k + 2) = 1 Then
strS = "A" & tr & ":C" & tr
strD = "D" & tr & ":R" & tr
Workbooks(wb).Sheets(rez).Range(strS).Value = arr(1, k + 2): Workbooks(wb).Sheets(rez).Range(strD).Value = arr(2, k + 2): tr = tr + 1
End If
Next k

tr = tr + 2
strS = "A1:Q1"
temp = Workbooks(wb).Sheets(tb1).Range(strS).Value
strS = "A" & tr & ":Q" & tr
Workbooks(wb).Sheets(rez).Range(strS).Value = temp
Workbooks(wb).Sheets(rez).Cells.EntireColumn.AutoFit
Workbooks(wb).Sheets(rez).Cells.WrapText = False
tr = tr + 1
For k = 0 To f
If nofind(k + 2) = 0 Then
strS = "A" & k + 2 & ":Q" & k + 2
strD = "A" & tr & ":Q" & tr
Workbooks(wb).Sheets(rez).Range(strD).Value = Workbooks(wb).Sheets(tb1).Range(strS).Value: tr = tr + 1
End If
Next k
Workbooks(wb).Sheets(rez).Cells.EntireColumn.AutoFit
Workbooks(wb).Sheets(rez).Cells.WrapText = False
Exit Sub
какашка:
If Err = 91 Then Resume Next
MsgBox Err & " - " & Err.Description, vbCritical, "Ошибка"
End Sub
[/vba]
Нашла здесь на форуме, тема http://www.excelworld.ru/forum/10-32276-1#209448
Пост http://www.excelworld.ru/forum/10-32276-209460-16-1486628477
Помогите пожалуйста подстроить под ми нужды. Всем спасибо)


Сообщение отредактировал Olena - Воскресенье, 14.11.2021, 23:33
 
Ответить
СообщениеХМ, нашла подходящий макрос, но вот подправить не могу, так как не знаю, как переписать Открыть файл в сети , прочитать лист, сравнить с листом ( они идентичны по структуре, разные по наполнению) и записать не совпадающие в низ и перезаписать, совпадающие (т.к. иногда будет кое что меняться.)
[vba]
Код
Sub tabsumm()
On Error GoTo какашка
Dim tb1, tb2, rez, wb, f, k, lr(2), strS, strD, str, tr, arr(), nofind(), ActR, temp
wb = ActiveWorkbook.Name
tb1 = "table1"
tb2 = "table2"
rez = "результат"
lr(1) = Workbooks(wb).Sheets(tb1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(2, lr(1))
ReDim nofind(lr(1))
lr(2) = Workbooks(wb).Sheets(tb2).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(wb).Sheets(rez).Cells.Clear
For f = 2 To lr(1)
str = Workbooks(wb).Sheets(tb1).Cells(f, 3).Value
Workbooks(wb).Sheets(tb2).Select
Workbooks(wb).Sheets(tb2).Cells(2, 1).Select
tr = 2
Workbooks(wb).Sheets(tb2).Cells.Find(What:=str, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActR = ActiveCell.Row
If ActR > tr Then
strS = "A" & f & ":C" & f
arr(1, f) = Workbooks(wb).Sheets(tb1).Range(strS).Value
strD = "C" & ActR & ":Q" & ActR
arr(2, f) = Workbooks(wb).Sheets(tb2).Range(strD).Value
nofind(f) = 1
Else
nofind(f) = 0
End If
Next f
f = f - 3
tr = 2
strS = "A1:C1"
strD = "A1:C1"
temp = Workbooks(wb).Sheets(tb1).Range(strS).Value
Workbooks(wb).Sheets(rez).Range(strD).Value = temp
strS = "C1:Q1"
strD = "D1:R1"
temp = Workbooks(wb).Sheets(tb2).Range(strS).Value
Workbooks(wb).Sheets(rez).Range(strD).Value = temp
Workbooks(wb).Sheets(rez).Cells.EntireColumn.AutoFit
Workbooks(wb).Sheets(rez).Cells.WrapText = False

For k = 0 To f
If nofind(k + 2) = 1 Then
strS = "A" & tr & ":C" & tr
strD = "D" & tr & ":R" & tr
Workbooks(wb).Sheets(rez).Range(strS).Value = arr(1, k + 2): Workbooks(wb).Sheets(rez).Range(strD).Value = arr(2, k + 2): tr = tr + 1
End If
Next k

tr = tr + 2
strS = "A1:Q1"
temp = Workbooks(wb).Sheets(tb1).Range(strS).Value
strS = "A" & tr & ":Q" & tr
Workbooks(wb).Sheets(rez).Range(strS).Value = temp
Workbooks(wb).Sheets(rez).Cells.EntireColumn.AutoFit
Workbooks(wb).Sheets(rez).Cells.WrapText = False
tr = tr + 1
For k = 0 To f
If nofind(k + 2) = 0 Then
strS = "A" & k + 2 & ":Q" & k + 2
strD = "A" & tr & ":Q" & tr
Workbooks(wb).Sheets(rez).Range(strD).Value = Workbooks(wb).Sheets(tb1).Range(strS).Value: tr = tr + 1
End If
Next k
Workbooks(wb).Sheets(rez).Cells.EntireColumn.AutoFit
Workbooks(wb).Sheets(rez).Cells.WrapText = False
Exit Sub
какашка:
If Err = 91 Then Resume Next
MsgBox Err & " - " & Err.Description, vbCritical, "Ошибка"
End Sub
[/vba]
Нашла здесь на форуме, тема http://www.excelworld.ru/forum/10-32276-1#209448
Пост http://www.excelworld.ru/forum/10-32276-209460-16-1486628477
Помогите пожалуйста подстроить под ми нужды. Всем спасибо)

Автор - Olena
Дата добавления - 14.11.2021 в 23:32
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Задваивание копируемых данных (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования Jobsora jooble
© 2010-2021 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!