ReSQL.ru
     
powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Перенос данных с одного листа на другой
9 сообщений из 9, страница 1 из 1
Перенос данных с одного листа на другой
    #33933353
AlexanderKR
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AlexanderKR
Гость
Помогите решить такую проблему.
Мне необходимо перенести информацию
из одного листа Excel в другой (всего - 2 листа).
Если значения двух ячеек одного листа совпадают
с значениями второго, то значение третьей ячейки
должно перенестись в соответствующий столбец
второго листа.
Ниже привожу рабочий код, но работате он
как черепаха (200 записей за 5 минут).

' ====
Sub transfer_macro()

stroka = 4
stroka1 = 4

Spisok_from = "Лист1"
Spisok_into = "Лист2"

ActiveWorkbook.ActiveSheet.Cells(1, 1).Select

Do While Sheets(Spisok_from).Cells(stroka, 2) <> "" Or Sheets(Spisok_from).Cells(stroka, 3) <> "" Or Sheets(Spisok_from).Cells(stroka, 1) <> ""
dogovor = Sheets(Spisok_from).Cells(stroka, 2) ' Spisok_from
kod_sch = Sheets(Spisok_from).Cells(stroka, 4)
pokaz_1 = Sheets(Spisok_from).Cells(stroka, 28)

With Worksheets(Spisok_into).Range("a:bb") 'Spisok_into
Worksheets(Spisok_into).Activate
stroka1 = 4

Do While Sheets(Spisok_into).Cells(stroka1, 2) <> "" Or Sheets(Spisok_into).Cells(stroka1, 3) <> "" Or Sheets(Spisok_into).Cells(stroka1, 1) <> ""

dog_2 = Sheets(Spisok_into).Cells(stroka1, 2).Value 'Spisok_into
kod_s_2 = Sheets(Spisok_into).Cells(stroka1, 4).Value
pokaz_2 = Sheets(Spisok_into).Cells(stroka1, 28).Value

If dog_2 = dogovor And kod_s_2 = kod_sch Then
ActiveCell.Select

If pokaz_1 <> "" Then
Sheets(Spisok_into).Cells(stroka1, 28).Value = pokaz_1
End If

Sheets(Spisok_into).Cells(stroka1, 28).Activate
End If

stroka1 = stroka1 + 1
Loop

End With

stroka = stroka + 1

Loop

End Sub

' =============================

Помогите оптимизировать, пожалуйста.
Спасибо.
...
Рейтинг: 0 / 0
21.08.2006, 22:24:44
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33933594
isbn
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
isbn
Гость
Тормозит скорее всего Activate - активная ячейка туда-сюда прыгает. Избегать следует Activate и Select в макросах.
...
Рейтинг: 0 / 0
22.08.2006, 09:01:19
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33933619
Taranaga
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Taranaga
Участник
А еще можно автопересчет вырубить предварительно. Тоже оч полезно :)
...
Рейтинг: 0 / 0
22.08.2006, 09:11:11
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33933632
Taranaga
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Taranaga
Участник
Это в начале модуля написать
Код: plaintext
1.
2.
Calculate
Application.Calculation = xlManual
А это в конце
Код: plaintext
Application.Calculation = xlAutomatic
...
Рейтинг: 0 / 0
22.08.2006, 09:15:48
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33933643
vkodor
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
vkodor
Участник
попробуй
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
Sub transfer_macro()
    Dim rng As Range
    vr = Timer
    stroka =  4 
    
    Spisok_from = "Лист1"
    Spisok_into = "Лист2"
    
    Do While Sheets(Spisok_from).Cells(stroka,  2 ) <> "" Or _
                Sheets(Spisok_from).Cells(stroka,  3 ) <> "" Or _
                Sheets(Spisok_from).Cells(stroka,  1 ) <> ""
        With Sheets(Spisok_from)
            dogovor = .Cells(stroka,  2 ) ' Spisok_from
            kod_sch = .Cells(stroka,  4 )
            pokaz_1 = .Cells(stroka,  28 )
        End With
        If pokaz_1 <> "" Then
            With Worksheets(Spisok_into) 'Spisok_into
                Set rng = .Range("B:B").Find(What:=dogovor, LookIn:=xlValues, LookAt:= _
                    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
                If Not rng Is Nothing Then
                    Do
                        firstAddress = rng.Address
                        kod_s_2 = .Cells(rng.Row,  4 ).Value
                        'pokaz_2 = .Cells(rng.Row, 28).Value
                        If kod_s_2 = kod_sch Then _
                                .Cells(rng.Row,  28 ).Value = pokaz_1
                        Set rng = .Range("B:B").FindNext(rng)
                    Loop While Not rng Is Nothing And rng.Address <> firstAddress
                End If
                Set rng = Nothing
            End With
        End If
        stroka = stroka +  1 
    Loop
    MsgBox Timer - vr
End Sub
...
Рейтинг: 0 / 0
22.08.2006, 09:22:57
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33933852
AlexanderKR
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AlexanderKR
Гость
Спасибо за код, но цикл крутится на одном месте.
Т.е. есть колонки:
dogovor kod_sch pokaz1
1001 1 15
1001 2 18
1002 1 10

Так вот, он вписывает соответствующие значения
по договору 1001, но не переходит на договор 1002. Я пытался изменить условие, но не получилось. Зацикливание происходит на стадии:
Set rng = .Range("B:B").FindNext(rng)
...
Рейтинг: 0 / 0
22.08.2006, 10:47:15
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33933933
vkodor
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
vkodor
Участник
пардон ошибся
надо адрес firstAddress = rng.Address определять до цикла
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
Sub transfer_macro()
    Dim rng As Range
    vr = Timer
    stroka =  4 
    
    Spisok_from = "Лист1"
    Spisok_into = "Лист2"
    
    Do While Sheets(Spisok_from).Cells(stroka,  2 ) <> "" Or _
                Sheets(Spisok_from).Cells(stroka,  3 ) <> "" Or _
                Sheets(Spisok_from).Cells(stroka,  1 ) <> ""
        With Sheets(Spisok_from)
            dogovor = .Cells(stroka,  2 ) ' Spisok_from
            kod_sch = .Cells(stroka,  4 )
            pokaz_1 = .Cells(stroka,  28 )
        End With
        If pokaz_1 <> "" Then
            With Worksheets(Spisok_into) 'Spisok_into
                Set rng = .Range("B:B").Find(What:=dogovor, LookIn:=xlValues, LookAt:= _
                    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
                If Not rng Is Nothing Then
                    firstAddress = rng.Address
                    Do
                        kod_s_2 = .Cells(rng.Row,  4 ).Value
                        'pokaz_2 = .Cells(rng.Row, 28).Value
                        If kod_s_2 = kod_sch Then _
                                .Cells(rng.Row,  28 ).Value = pokaz_1
                        Set rng = .Range("B:B").FindNext(rng)
                    Loop While Not rng Is Nothing And rng.Address <> firstAddress
                End If
                Set rng = Nothing
            End With
        End If
        stroka = stroka +  1 
    Loop
    MsgBox Timer - vr
End Sub
...
Рейтинг: 0 / 0
22.08.2006, 11:09:13
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33935975
AlexanderKR
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
AlexanderKR
Гость
Все работает отлично, благодарю.
6000 строк за 60 секунд.
...
Рейтинг: 0 / 0
22.08.2006, 21:12:23
| Ответить | Цитировать | Написать  
Перенос данных с одного листа на другой
    #33936391
Taranaga
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Taranaga
Участник
60 секунд??? Чтото подтормаживает... А автопересчет выключен?
...
Рейтинг: 0 / 0
23.08.2006, 09:23:31
| Ответить | Цитировать | Написать  
9 сообщений из 9, страница 1 из 1
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Перенос данных с одного листа на другой
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение   Полит. конфиден.  
NoSQL.ru       Кролег: Проекты, Новости, Чат       РЕД ФОРУМ       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=61&msg=33933619&tid=2184417]:
 0ms
get settings:
 9ms
get forum list:
 22ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 74ms
get topic data:
 11ms
get forum data:
 2ms
get page messages:
 64ms
get tp. blocked users:
 2ms
others: 227ms
total:  417ms
созд. / загр.: 417ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]