Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 20.06.2020, 07:59   #1
Mkoty
Пользователь
 
Регистрация: 26.05.2020
Сообщений: 22
По умолчанию Долгая обработка таблицы

Добры день.
Существуют два листа таблицы, вроде всего ничего 350 строк.
но таааак долго обрабатывает
берет из списка одного листа и распределяет по другому листу.
что я лишнего накруговертил?
заранее спасибо

Код:
Sub ZZ()
Sheets("Лист2").Select
    Dim i, b, Kod, Kol, CenaVdoke, CenaOpt, NomerDoka, DataDoka, VidDoka, Klient, Vozvrat, Manager
    i = 1
    b = 12
    
    

    
    Do While Sheets("Лист2").Range("A" & i) <> ""

        Kod = Sheets("Лист2").Range("A" & i)
        Kol = Sheets("Лист2").Range("B" & i)
        CenaVdoke = Sheets("Лист2").Range("C" & i)
        CenaOpt = Sheets("Лист2").Range("D" & i)
        NomerDoka = Sheets("Лист2").Range("E" & i)
        DataDoka = Sheets("Лист2").Range("F" & i)
        VidDoka = Sheets("Лист2").Range("G" & i)
        Klient = Sheets("Лист2").Range("H" & i)
        Vozvrat = Sheets("Лист2").Range("I" & i)
        Manager = Sheets("Лист2").Range("J" & i)
        
                    Sheets("Лист1").Select
                    i = i + 1
        If VidDoka = "РР" Then
            VidDoka = "Расходная Розничная"
        ElseIf VidDoka = "РН2" Then
            VidDoka = "Расходная накладная 0.1"
            Sheets("Лист1").Range("H" & b).Value = Kol
            Sheets("Лист1").Range("H" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "РН" Then
            VidDoka = "Расходная накладная"
            Sheets("Лист1").Range("H" & b).Value = Kol
            Sheets("Лист1").Range("H" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "ПН1" Then
            VidDoka = "Приходная накладная 0.1"
            Sheets("Лист1").Range("G" & b).Value = Kol
            Sheets("Лист1").Range("G" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "ПН" Then
            VidDoka = "Приходная накладная"
            Sheets("Лист1").Range("G" & b).Value = Kol
            Sheets("Лист1").Range("G" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "ОР" Then
            VidDoka = "Отчет реализатора"
        ElseIf VidDoka = "ПРУ" Then
            VidDoka = "Приходая реализатора"
        Else
        End If
        Sheets("Лист1").Range("A" & b).Value = VidDoka
        Sheets("Лист1").Range("C" & b).Value = "№ " + NomerDoka
        Sheets("Лист1").Range("D" & b).Value = "от " + DataDoka
        If Klient = " ЧЛ " Then
            Sheets("Лист1").Range("E" & b).Value = "Частное Лицо"
        Else
            Sheets("Лист1").Range("E" & b).Value = Klient
        
        End If
        
        
                    
                   
                    b = b + 1
                    
    Loop

End Sub
Mkoty вне форума Ответить с цитированием
Старый 20.06.2020, 11:29   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Отключите перерисовку экрана
https://analysistabs.com/vba/optimiz...macros-faster/
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 20.06.2020, 13:45   #3
Igor1961
Пользователь
 
Регистрация: 05.10.2015
Сообщений: 39
По умолчанию

350 строк для такого кода не должно тормозить. Нужно файл смотреть - может там формулы какие-то при каждом чихе пересчитываются или еще что-то есть. И выравнивание в ячейках наверное можно не на каждое ElseIf делать, а один раз в конце - Range("G" & b & ":H" & b). А на других компьютерах тоже долго отрабатывает?
Да, и возможно лучше было бы просто For-Next чем Do While (не уверен, но вдруг?)
Igor1961 вне форума Ответить с цитированием
Старый 21.06.2020, 07:23   #4
Mkoty
Пользователь
 
Регистрация: 26.05.2020
Сообщений: 22
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Отключите перерисовку экрана
https://analysistabs.com/vba/optimiz...macros-faster/
сделал.
спасибо.
но оказывается проблема в другой обработке ))

что то я с запуском обработок накруговертил
Код:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim PosStr
Application.ScreenUpdating = False
Dim sglStart As Single
sglStart = Timer
PosStr = Sheets("Лист1").UsedRange.Rows.Count
Sheets("Лист1").Range(Range("A12"), Range("A" & PosStr)).EntireRow.Delete


    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Sheets("Лист1").Range("A1")) Is Nothing Then
            Dim strFilePath As String
            Dim tm As String
            
            strFilePath = "MyTestFile.txt"
            tm = "*" + Sheets("Лист1").Cells(1, 1) + "*"
            Call ImportFromTxt(ActiveWorkbook.Path & "\Текст.txt", tm)
            Call ImportFromTxt1(ActiveWorkbook.Path & "\номенклатура.txt", tm)
            Call ImportFromTxt2(ActiveWorkbook.Path & "\начальные.txt", tm)
          
        End If
    Call ZZ
Sheets("Лист1").Range("G11").Value = WorksheetFunction.Sum(Range("G12:G5" & PosStr))

Sheets("Лист1").Select
Application.ScreenUpdating = True
MsgBox Timer - sglStart
End Sub
потому что установив счетчик времени он стал выдавать время по переносу каждой строки

и вот я еще чего не могу понять
файл с VBA в формате .xlsm весит 43 мегабайта, там текста ноль повдоль.
вот весь макрос:
Код:
Option Explicit
Sub ImportFromTxt(ByVal strFilePath As String, ByVal strLike As String)
    Const ForReading As Byte = 1
    
    Dim i As Long
    Dim tmp
    Dim fso As Object, tso As Object
    Dim strLine As String
    Dim x As Long: x = 1
    
    Set fso = CreateObject("Scripting.FileSystemObject")      '
    Set tso = fso.OpenTextFile(strFilePath, ForReading)
    
    i = 1
    Sheets("Лист2").Select
    Sheets("Лист2").Cells.Select
    Application.CutCopyMode = False
    Selection.ClearContents
    
    Do While Not tso.AtEndOfStream        '
        strLine = tso.ReadLine
        If Left(strLine, 6) Like strLike Then
            tmp = Split(strLine, vbTab)
            Sheets("Лист2").Cells(x, 1).Resize(1, UBound(tmp)) = tmp
            x = x + 1
        End If
        i = i + 1
    Loop
    
    tso.Close
    Set tso = Nothing
    
    Set fso = Nothing

End Sub

Sub ImportFromTxt1(ByVal strFilePath As String, ByVal strLike As String)
    Const ForReading As Byte = 1
    
    Dim i As Long
    Dim tmp
    Dim fso As Object, tso As Object
    Dim strLine As String
    Dim x As Long: x = 1
    
    Set fso = CreateObject("Scripting.FileSystemObject")      '
    Set tso = fso.OpenTextFile(strFilePath, ForReading)
    
    i = 1
    Sheets("Лист3").Select
    Sheets("Лист3").Cells.Select
    Application.CutCopyMode = False
    Selection.ClearContents
    
    Do While Not tso.AtEndOfStream        '
        strLine = tso.ReadLine
        If strLine Like strLike Then
            tmp = Split(strLine, "|")
            Sheets("Лист3").Cells(x, 1).Resize(1, UBound(tmp)) = tmp
            x = x + 1
        End If
        i = i + 1
    Loop
    
    tso.Close
    Set tso = Nothing
    
    Set fso = Nothing
End Sub
Sub ImportFromTxt2(ByVal strFilePath As String, ByVal strLike As String)
    Const ForReading As Byte = 1
    
    Dim i As Long
    Dim tmp
    Dim fso As Object, tso As Object
    Dim strLine As String
    Dim x As Long: x = 1
    
    Set fso = CreateObject("Scripting.FileSystemObject")      '
    Set tso = fso.OpenTextFile(strFilePath, ForReading)
    
    i = 1
    Sheets("Лист4").Select
    Sheets("Лист4").Cells.Select
    Application.CutCopyMode = False
    Selection.ClearContents
    
    Do While Not tso.AtEndOfStream        '
        strLine = tso.ReadLine
        If strLine Like strLike Then
            tmp = Split(strLine, vbTab)
            Sheets("Лист4").Cells(x, 1).Resize(1, UBound(tmp)) = tmp
            x = x + 1
        End If
        i = i + 1
    Loop
    
    tso.Close
    Set tso = Nothing
    
    Set fso = Nothing
    Sheets("Лист1").Select
End Sub
Sub ZZ()
Sheets("Лист2").Select
    Dim i, b, Kod, Kol, CenaVdoke, CenaOpt, NomerDoka, DataDoka, VidDoka, Klient, Vozvrat, Manager
    i = 1
    b = 12
    
    

    
    Do While Sheets("Лист2").Range("A" & i) <> ""

        Kod = Sheets("Лист2").Range("A" & i)
        Kol = Sheets("Лист2").Range("B" & i)
        CenaVdoke = Sheets("Лист2").Range("C" & i)
        CenaOpt = Sheets("Лист2").Range("D" & i)
        NomerDoka = Sheets("Лист2").Range("E" & i)
        DataDoka = Sheets("Лист2").Range("F" & i)
        VidDoka = Sheets("Лист2").Range("G" & i)
        Klient = Sheets("Лист2").Range("H" & i)
        Vozvrat = Sheets("Лист2").Range("I" & i)
        Manager = Sheets("Лист2").Range("J" & i)
        
                    Sheets("Лист1").Select
                    i = i + 1
        If VidDoka = "РР" Then
            VidDoka = "Расходная Розничная"
        ElseIf VidDoka = "РН2" Then
            VidDoka = "Расходная накладная 0.1"
            Sheets("Лист1").Range("H" & b).Value = CCur(Kol)
            Sheets("Лист1").Range("H" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "РН" Then
            VidDoka = "Расходная накладная"
            Sheets("Лист1").Range("H" & b).Value = CCur(Kol)
            Sheets("Лист1").Range("H" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "ПН1" Then
            VidDoka = "Приходная накладная 0.1"
            Sheets("Лист1").Range("G" & b).Value = CCur(Kol)
            Sheets("Лист1").Range("G" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "ПН" Then
            VidDoka = "Приходная накладная"
            Sheets("Лист1").Range("G" & b).Value = CCur(Kol)
            Sheets("Лист1").Range("G" & b).HorizontalAlignment = xlRight
        ElseIf VidDoka = "ОР" Then
            VidDoka = "Отчет реализатора"
        ElseIf VidDoka = "ПРУ" Then
            VidDoka = "Приходная реализатора"
        Else
        End If
        Sheets("Лист1").Range("A" & b).Value = VidDoka
        Sheets("Лист1").Range("C" & b).Value = "№ " + NomerDoka
        Sheets("Лист1").Range("D" & b).Value = "от " + DataDoka
        If Klient = " ЧЛ " Then
            Sheets("Лист1").Range("E" & b).Value = "Частное Лицо"
        Else
            Sheets("Лист1").Range("E" & b).Value = Klient
        
        End If
        
        
                    
                   
                    b = b + 1
                    
    Loop

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim PosStr
Application.ScreenUpdating = False
Dim sglStart As Single
sglStart = Timer
PosStr = Sheets("Лист1").UsedRange.Rows.Count
Sheets("Лист1").Range(Range("A12"), Range("A" & PosStr)).EntireRow.Delete


    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Sheets("Лист1").Range("A1")) Is Nothing Then
            Dim strFilePath As String
            Dim tm As String
            
            strFilePath = "MyTestFile.txt"
            tm = "*" + Sheets("Лист1").Cells(1, 1) + "*"
            Call ImportFromTxt(ActiveWorkbook.Path & "\Текст.txt", tm)
            Call ImportFromTxt1(ActiveWorkbook.Path & "\номенклатура.txt", tm)
            Call ImportFromTxt2(ActiveWorkbook.Path & "\начальные.txt", tm)
          
        End If
    Call ZZ
Sheets("Лист1").Range("G11").Value = WorksheetFunction.Sum(Range("G12:G5" & PosStr))

Sheets("Лист1").Select
Application.ScreenUpdating = True
MsgBox Timer - sglStart
End Sub
и два листа в каждом по 350 строк

Последний раз редактировалось Mkoty; 21.06.2020 в 07:33.
Mkoty вне форума Ответить с цитированием
Старый 21.06.2020, 08:42   #5
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

На каждый чих на листе запускать удаление е 3 импорта? Как-либо по-другому реализовать решение не получается?

Первый макрос, формула суммы, зачем G5: а не просто G?

43 мб. Формул много, условного форматирования ячеек?

Данных на 350 строк, а сколько строк листа используется?
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 22.06.2020, 05:51   #6
Mkoty
Пользователь
 
Регистрация: 26.05.2020
Сообщений: 22
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Первый макрос, формула суммы, зачем G5: а не просто G?
это очепятка, исправил, спасибо
Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
На каждый чих на листе запускать удаление е 3 импорта? Как-либо по-другому реализовать решение не получается?
вроде делал на изменение 1й "А1" ячейки, а вышло что на любой.
сделал через изменение TextBox1
Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
43 мб. Формул много, условного форматирования ячеек?
как таковых формул вообще нет.
по факту обработка сканирует текстовые файлы заполняя один лист - один файл, после из этих листов переформатируя заполняет главный (тут в дальнейшем будут варианты)
как таковых формул нет
Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Данных на 350 строк, а сколько строк листа используется?
65к строк в двух листах. поправил и размер файла ушел, Спасибо

Последний раз редактировалось Mkoty; 22.06.2020 в 07:27.
Mkoty вне форума Ответить с цитированием
Старый 22.06.2020, 07:27   #7
Mkoty
Пользователь
 
Регистрация: 26.05.2020
Сообщений: 22
По умолчанию

7 секунд вышло, что тоже долго.
и сумму в столбце G не считает надо с 12й по последнюю строку

Цитата:
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
Application.ScreenUpdating = False
Dim sglStart As Single
sglStart = Timer
Dim strFilePath As String
Dim tm As String

Dim PosStr
PosStr = Sheets("Лист1").UsedRange.Rows.Coun t

If PosStr > 11 Then
Sheets("Лист1").Range(Range("A12"), Range("I" & PosStr)).EntireRow.Delete
End If

Call ZZ

Sheets("Лист1").Select
Sheets("Лист1").Range("G11").Value = WorksheetFunction.Sum(Range("G" & PosStr))

Sheets("Лист1").Select
Application.ScreenUpdating = True
MsgBox Timer - sglStart
End If
End Sub

Последний раз редактировалось Mkoty; 22.06.2020 в 07:32.
Mkoty вне форума Ответить с цитированием
Старый 22.06.2020, 13:46   #8
Mkoty
Пользователь
 
Регистрация: 26.05.2020
Сообщений: 22
По умолчанию

Вот файл который получился.
при нажатии ввод в первой ячейке запускаются обработки
но 10 секунд обработка очень долгая.
как можно ускорить?
Вложения
Тип файла: rar рабочий.rar (75.4 Кб, 3 просмотров)
Mkoty вне форума Ответить с цитированием
Старый 22.06.2020, 14:30   #9
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

4.3 сек с .Select
3.8 сек если убрать .Select"ы ненужные

ImportFromTxt все отличия в них только в листе на которые выводить данные. Передавайте 3м параметром лист на который выводить инфо - уберете повторы однообразного кода
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 23.06.2020, 11:06   #10
Mkoty
Пользователь
 
Регистрация: 26.05.2020
Сообщений: 22
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
4.3 сек с .Select
3.8 сек если убрать .Select"ы ненужные

ImportFromTxt все отличия в них только в листе на которые выводить данные. Передавайте 3м параметром лист на который выводить инфо - уберете повторы однообразного кода
Спасибо! очень помогло.
Вложения
Тип файла: rar рабочий.rar (80.2 Кб, 5 просмотров)

Последний раз редактировалось Mkoty; 23.06.2020 в 11:08.
Mkoty вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Обработка таблицы макросом Dorina Microsoft Office Excel 9 22.04.2011 19:24
Обработка символьных массивов. Вывод кодовой таблицы. Manya-srt Помощь студентам 0 08.11.2010 17:05
обработка таблицы в Microsoft Office Excel 2007 leoleonid Microsoft Office Excel 2 08.09.2010 19:02
Обработка таблицы Anatoly_K Microsoft Office Excel 12 03.06.2010 19:12