Ребят, подскажите, есть код который исправно работает на 100 и 1000 записей, ставлю реестр в 70000, виснет на долгое время, что в принципе логично.
Берем 3 столбца в таблице, запускаем цикл по всем записям и смотрим если такие же столбцы уже есть выше по списку то ставим 0, если это уникальное сочитание столбцов то ставим 1.
Соответственно получается, что чем дальше он вниз по списку идет, тем больше ему приходится перемалывать записей. Что тут можно придумать?
Берем 3 столбца в таблице, запускаем цикл по всем записям и смотрим если такие же столбцы уже есть выше по списку то ставим 0, если это уникальное сочитание столбцов то ставим 1.
Соответственно получается, что чем дальше он вниз по списку идет, тем больше ему приходится перемалывать записей. Что тут можно придумать?
Код |
---|
Sub √руппировка_продуктов_за_мес€ц() Dim id As String Dim product As String Dim mouth As String Dim idCheck As String Dim productCheck As String Dim mouthCheck As String Dim arrayId As Variant Dim arrayProduct As Variant Dim arrayMouth As Variant SheetName = "list1" lastRow = Sheets(SheetName).Cells(Rows.Count, "U").End(xlUp).Row arrayId = Range("U2:U" & lastRow).Value arrayProduct = Range("DU2:DU" & lastRow).Value arrayMouth = Range("EI2:EI" & lastRow).Value For i = 1 To lastRow - 1 id = arrayId(i, 1) product = arrayProduct(i, 1) mouth = arrayMouth(i, 1) Sheets(SheetName).Cells(i + 1, "EJ").Value = 1 For j = 1 To i - 1 idCheck = arrayId(j, 1) productCheck = arrayProduct(j, 1) mouthCheck = arrayMouth(j, 1) If (id = idCheck AND product=productCheck AND mouth = nouthCheck) Then Sheets(SheetName).Cells(i + 1, "EJ").Value = 0 Exit For End If Next Next End Sub |