Здравствуйте, уважаемые форумчане! Необходима помощь в решении задачи. Дано: два листа в книге. На листе 1 в столбце «A» код товара, в столбце «B» названия отделов, столбцы «C», «D», «E» содержат некоторые значения (с 1 по 3). На листе 2 в столбце «A» код товара, в строке 1 названия отделов, строке 2 названия перечень значения с 1 по 3. Необходимо: проставить в соответствующие столбцы листа 2 показатели значений из листа 1. Макрос написал, но он работает очень медленно, когда возможных кодов товара на листе 2 больше 1500, а строк на листе один более 50000. Время работы с таким макросом составляет более 2 часов. Есть ли возможность оптимизировать его работу? Спасибо!
Здравствуйте, уважаемые форумчане! Необходима помощь в решении задачи. Дано: два листа в книге. На листе 1 в столбце «A» код товара, в столбце «B» названия отделов, столбцы «C», «D», «E» содержат некоторые значения (с 1 по 3). На листе 2 в столбце «A» код товара, в строке 1 названия отделов, строке 2 названия перечень значения с 1 по 3. Необходимо: проставить в соответствующие столбцы листа 2 показатели значений из листа 1. Макрос написал, но он работает очень медленно, когда возможных кодов товара на листе 2 больше 1500, а строк на листе один более 50000. Время работы с таким макросом составляет более 2 часов. Есть ли возможность оптимизировать его работу? Спасибо!is_1
Sub Sbor() Dim i As Long Dim iLastRow As Long Dim FoundCell As Range Dim FAdr As String Dim iStolb As Integer iLastRow = Cells(Rows.Count, 1).End(xlUp).Row Range("B3:P" & iLastRow).ClearContents With Worksheets("1") For i = 3 To iLastRow Set FoundCell = .Columns(1).Find(Cells(i, 1), , xlValues, xlWhole) If Not FoundCell Is Nothing Then FAdr = FoundCell.Address Do Select Case FoundCell.Offset(, 1) Case "department_1" iStolb = 2 Case "department_2" iStolb = 5 Case "department_3" iStolb = 8 Case "department_4" iStolb = 11 Case "department_5" iStolb = 14 End Select .Range(.Cells(FoundCell.Row, 3), .Cells(FoundCell.Row, 5)).Copy Cells(i, iStolb) Set FoundCell = .Columns(1).FindNext(FoundCell) Loop While FoundCell.Address <> FAdr End If Next End With End Sub
[/vba]
Макрос, запускать при активном листе "2" [vba]
Код
Sub Sbor() Dim i As Long Dim iLastRow As Long Dim FoundCell As Range Dim FAdr As String Dim iStolb As Integer iLastRow = Cells(Rows.Count, 1).End(xlUp).Row Range("B3:P" & iLastRow).ClearContents With Worksheets("1") For i = 3 To iLastRow Set FoundCell = .Columns(1).Find(Cells(i, 1), , xlValues, xlWhole) If Not FoundCell Is Nothing Then FAdr = FoundCell.Address Do Select Case FoundCell.Offset(, 1) Case "department_1" iStolb = 2 Case "department_2" iStolb = 5 Case "department_3" iStolb = 8 Case "department_4" iStolb = 11 Case "department_5" iStolb = 14 End Select .Range(.Cells(FoundCell.Row, 3), .Cells(FoundCell.Row, 5)).Copy Cells(i, iStolb) Set FoundCell = .Columns(1).FindNext(FoundCell) Loop While FoundCell.Address <> FAdr End If Next End With End Sub
is_1, будет куда быстрее сначала скопировать все данные в массивы и производить все операции с массивами, а результат уже помещать на лист. Альтернативно, можно воспользоваться SQL запросом.
is_1, будет куда быстрее сначала скопировать все данные в массивы и производить все операции с массивами, а результат уже помещать на лист. Альтернативно, можно воспользоваться SQL запросом.iMrTidy
Вышенаписанное мной не является истиной, но лишь моя точка зрения, которая скорее всего ошибочна.
Sub ertert() Dim tm!: tm = Timer Dim x, y(), i&, j&, k&, n&, m&
With Sheets("1") x = .Range("A1:E" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With ReDim y(1 To UBound(x), 1 To 13): j = 2: k = -1
On Error Resume Next With New Collection For i = 2 To UBound(x, 1) If IsEmpty(.Item(x(i, 1))) Then 'код_товара j = j + 1: n = j .Add j, x(i, 1) y(j, 1) = x(i, 1) Else n = .Item(x(i, 1)) End If
If IsEmpty(.Item(x(i, 2))) Then 'код_отдела k = k + 3: m = k .Add k, x(i, 2) If k > UBound(y, 2) Then ReDim Preserve y(1 To UBound(y), 1 To UBound(y, 2) * 2) y(1, k) = x(i, 2) Else m = .Item(x(i, 2)) End If y(n, m) = x(i, 3) y(n, m + 1) = x(i, 4) y(n, m + 2) = x(i, 5) Next i End With On Error GoTo 0
y(1, 1) = "код_товара" Sheets("2").Range("A1").Resize(j, k + 2).Value = y() MsgBox Timer - tm End Sub
[/vba]
в качестве варианта
[vba]
Код
Sub ertert() Dim tm!: tm = Timer Dim x, y(), i&, j&, k&, n&, m&
With Sheets("1") x = .Range("A1:E" & .Cells(Rows.Count, 1).End(xlUp).Row).Value End With ReDim y(1 To UBound(x), 1 To 13): j = 2: k = -1
On Error Resume Next With New Collection For i = 2 To UBound(x, 1) If IsEmpty(.Item(x(i, 1))) Then 'код_товара j = j + 1: n = j .Add j, x(i, 1) y(j, 1) = x(i, 1) Else n = .Item(x(i, 1)) End If
If IsEmpty(.Item(x(i, 2))) Then 'код_отдела k = k + 3: m = k .Add k, x(i, 2) If k > UBound(y, 2) Then ReDim Preserve y(1 To UBound(y), 1 To UBound(y, 2) * 2) y(1, k) = x(i, 2) Else m = .Item(x(i, 2)) End If y(n, m) = x(i, 3) y(n, m + 1) = x(i, 4) y(n, m + 2) = x(i, 5) Next i End With On Error GoTo 0
y(1, 1) = "код_товара" Sheets("2").Range("A1").Resize(j, k + 2).Value = y() MsgBox Timer - tm End Sub