Перенос данных в новую таблицу с условием

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Перенос данных в новую таблицу с условием (Макросы Sub)

kvadimod

Дата: Воскресенье, 16.02.2014, 23:12 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

Всем доброго вечера.
Подскажите пожалуйста, есть вопрос по файлу созданному ещё в 2011 в теме Excel, в вопросе 2-475-1. Очень замечательно им пользовался, но вот изменилась форма отчёта и ещё некоторые моменты и получилось... точнее перестало получаться, всё что до этого было замечательно!
Есть несколько вопросов - просьб о помощи. Попробую по порядку.
1. Вопрос по макросу (ertert). Изменилась форма исходного отчёта - в названиях клиентов (лист "Отчёт", строка 25) отсутствует адрес, есть только код и название клиента. Я добавил лист "ОБК" с информацией по адресам, соответствующей 9-и значному коду. Можно ли поправить этот макрос так, чтобы на лист "Сводный" в строку 4 перемещались не названия клиентов с кодом, с листа "Отчёт", а соответствующее название с адресом, с листа "ОБК" (можно без кода)? Правда на листе "Отчёт, код 10-и значный, впереди за чем то добавлен 0 (ноль)(?).

PS: все таблицы сокращены для уменьшения размера файла.

К сообщению приложен файл: kvadimod_fin_14.rar (79.5 Kb)

Вадимка

Сообщение отредактировал kvadimod - Воскресенье, 16.02.2014, 23:16

Ответить

kvadimod

Дата: Понедельник, 17.02.2014, 21:06 | Сообщение № 2

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

То ли я не в тему написал, то ли не понятно... тишина какая то?

Вадимка

Ответить

Wasilich

Дата: Понедельник, 17.02.2014, 23:15 | Сообщение № 3

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация: 326 ±

Замечаний: 0% ±

2003

Код чисто для переноса, должен работать.
[vba]

Код

Sub qqq()
Dim i&, nr&, st&
       For i = 2 To Sheets("Отчёт").Cells(25, Columns.Count).End(xlToLeft).Column
         nr = Val(Left(Sheets("Отчёт").Cells(25, i), 10))
         If nr > 0 Then
            st = WorksheetFunction.Match(nr, Sheets("ОБК").Range("A:A"), 0)
            Sheets("СВОДНЫЙ").Cells(4, i + 1) = Sheets("ОБК").Cells(st, 2)
         End If
       Next
End Sub

[/vba]

Сообщение отредактировал Wasilic - Вторник, 18.02.2014, 00:27

Ответить

kvadimod

Дата: Вторник, 18.02.2014, 00:15 | Сообщение № 4

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

Спасибо. Подскажи пожалуйста, что может быть не так? Выдаёт ошибку и выделяет эту строку жёлтым?
[vba]

Код

st = WorksheetFunction.Match(n, Sheets("ОБК").Range("A:A"), 0)

[/vba]
"Не возможно получить свойство Match класса WorksheetFunction"

Вадимка

Ответить

Serge_007

Дата: Вторник, 18.02.2014, 00:21 | Сообщение № 5

Группа: Админы

Ранг: Местный житель

Сообщений: 16475

Репутация: 2750 ±

Замечаний: ±

Excel 2016

Переменной n нет в коде, должно быть так:[vba]

Код

st = WorksheetFunction.Match(nr, Sheets("ОБК").Range("A:A"), 0)

[/vba]

ЮMoney:41001419691823 | WMR:126292472390

Ответить

Wasilich

Дата: Вторник, 18.02.2014, 00:22 | Сообщение № 6

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация: 326 ±

Замечаний: 0% ±

2003

Ошибка при написании, должно быть nr и st. Исправил в коде.
[vba]

Код

st = WorksheetFunction.Match(nr, Sheets("ОБК").Range("A:A"), 0)
Sheets("СВОДНЫЙ").Cells(4, i + 1) = Sheets("ОБК").Cells(st, 2)

[/vba]ЗЫ. Сергей опередил.

Сообщение отредактировал Wasilic - Вторник, 18.02.2014, 00:29

Ответить

kvadimod

Дата: Вторник, 18.02.2014, 00:34 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

Теперь что то на следующую строку ругается

Вадимка

Ответить

kvadimod

Дата: Вторник, 18.02.2014, 00:38 | Сообщение № 8

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

Спасибо огромное всё сразу заработало как надо!

Вадимка

Ответить

kvadimod

Дата: Вторник, 18.02.2014, 09:12 | Сообщение № 9

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

Упс... снова что то не пошло...
После того, как обновил отчёт за неделю и количество клиентов увеличилось до 76, снова выдал ошибку в этоой строке
[vba]

Код

st = WorksheetFunction.Match(nr, Sheets("ОБК").Range("A:A"), 0)

[/vba]
Точнее он подставляет нужные значения как подожено, а потом выскакивает окно с ошибкой...

И может ещё подскажете, какого шрифта может не хватать? Русский шрифт в редакторе отображает "Îò÷¸ò"

Вадимка

Сообщение отредактировал kvadimod - Вторник, 18.02.2014, 09:19

Ответить

Андрей_М

Дата: Вторник, 18.02.2014, 17:34 | Сообщение № 10

Группа: Пользователи

Ранг: Прохожий

Сообщений: 1

Репутация: 0 ±

Замечаний: 40% ±

Excel 2010

Доброго Вечера, накомал макрос переносящий строку из листа в лист с удалением оригинала,
а мне нужно что бы он только копировал (Только данные и вставлял как показано в Примере)
вот сам код правда я его к файлу "Пример" не смог прикрутить вовсе

[vba]

Код

Private Sub Worksheet_Activate()

End Sub

'весь макрос переносит строку при 2-м клике в столбце "" на лист 2 с удалением оригинала на лист 1
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 6 Then Exit Sub
If Target <> "" Then Exit Sub
Dim lr&, sh As Worksheet
Set sh = Worksheets("Ком_Пред")
lr = sh.Cells(sh.Rows.Count, 17).End(xlUp).Row
Target = Date
Target.EntireRow.Copy sh.Cells(lr + 1, 1)
'Target.EntireRow.Delete 'удаление строки при переносе
Cancel = True

End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

End Sub

Private Sub Worksheet_Calculate()

End Sub

[/vba]

файл Пример прилагается, буду благодарен любой помощи

Вопрос снят разобрался сам
получилось так:
[vba]

Код

Sub Ìàêðîñ1()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells(Rows.Count, 12).End(xlUp).Row
Range("$A$27:$L" & LastRow).AutoFilter Field:=12, Criteria1:="ÈÑÒÈÍÀ"
Range("A2:O" & LastRow).SpecialCells(xlCellTypeVisible).Copy Sheets("Êîì_Ïðåä").[a16]
Range("A14:K" & LastRow).AutoFilter
Application.ScreenUpdating = True
End Sub

[/vba]

К сообщению приложен файл: 5336818.xlsm (53.6 Kb)

Сообщение отредактировал Serge_007 - Вторник, 18.02.2014, 22:28

Ответить

Wasilich

Дата: Вторник, 18.02.2014, 23:40 | Сообщение № 11

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация: 326 ±

Замечаний: 0% ±

2003

Цитата kvadimod, 18.02.2014 в 09:12, в сообщении № 9

количество клиентов увеличилось до 76, снова выдал ошибку

И каким образом, я или кто-то другой, может это проверить, отследить. Нам что, самим создавать пример и увеличивать к-во до 76-и.?????

Цитата kvadimod, 18.02.2014 в 09:12, в сообщении № 9

отображает "Îò÷¸ò"

У меня тоже так бывает, но это в познаниях VBA не самое главное, один раз несколько символов и ручками можно заменить.

Сообщение отредактировал Wasilic - Вторник, 18.02.2014, 23:41

Ответить

kvadimod

Дата: Среда, 19.02.2014, 20:31 | Сообщение № 12

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

Добрый день всем.
Wasilic, Всё нормально, я сам косякнул. После нового и дальнейших открытий файла всё работает на Ура! Спасибо огромное!

По поводу крякозябр, пробовал править руками, копировать с другим шрифтом - не помогает, может с раскладкой чего, или какого шрифта не хватает...

Ещё раз спасибо за помощь. Первая проблема после смены формы отчёта решена.

Вадимка

Сообщение отредактировал kvadimod - Среда, 19.02.2014, 20:52

Ответить

kvadimod

Дата: Вторник, 04.03.2014, 13:45 | Сообщение № 13

Группа: Пользователи

Ранг: Участник

Сообщений: 92

Репутация: 0 ±

Замечаний: 40% ±

Excel 2013

Цитата kvadimod, 19.02.2014 в 20:31, в сообщении № 12

По поводу крякозябр, пробовал править руками, копировать с другим шрифтом - не помогает, может с раскладкой чего, или какого шрифта не хватает...

Вопрос решён, если кому поможет в Tools=>Options=>Editor Format выбрать шрифт Courient New (Cyrilic), по умолчанию был Courient New (Western). После смены шрифта, все крякозабры стали очень даже понятным текстом.

Вадимка

Ответить

Перенос данных в новую таблицу с условием (Макросы Sub)

Страница 1 из 1
1