andrewkard1980
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору Fsp050 Пробуйте, обратите внимание на комментарии, можно ограничить глубину поиска: Код: Sub GetMaxR2() Dim y%, x1%, x2%, l%, i%, iMin%, iMax%, v, k%, a(), b(), c, lLr%, g% y = 3 Application.ScreenUpdating = False If ThisWorkbook.Worksheets.Count < 2 Then ThisWorkbook.Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count) Worksheets(1).Activate End If iMin = 4 iMax = Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column lLr = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row For k = 3 To iMax - 1 l = 0: g = 0 Do Until l = 1 ' количество найденных R2 для одной переменной DoEvents x1 = Int((iMax - iMin + 1) * Rnd + iMin) x2 = Int((iMax - iMin + 1) * Rnd + iMin) If x2 < x1 Then x2 = x1 + 1 c = Worksheets(1).Range(Cells(1, x1), Cells(1, x2)) Range("AX2:AX4").Select Selection.FormulaArray = "=LINEST(R2C" & y & ":R" & lLr & "C" & y & ",R2C" & x1 & ":R" & lLr & "C" & x2 & ",1,1)" With Worksheets(2) v = Worksheets(1).Range("AX4").Value If IsNumeric(v) = True Then If v > 0.5 Then i = .Cells(Rows.Count, "A").End(xlUp).Row .Cells(i + 1, 1) = Worksheets(1).Range("AX4").Value .Cells(i + 1, 2) = " " & x1 & " - " & x2 .Cells(i + 1, 3) = Worksheets(1).Cells(1, y).Value .Range(.Cells(i + 1, 5), .Cells(i + 1, x2 - x1 + 5)) = c l = l + 1 End If End If End With g = g + 1 If g = 10 Then Exit Do ' количество итераций Loop ThisWorkbook.Save With Worksheets(1) a = Application.Transpose(.Range(.Cells(1, 3), .Cells(lLr, 3))) b = Application.Transpose(.Range(.Cells(1, k + 1), .Cells(lLr, k + 1))) .Range(.Cells(1, 3), .Cells(lLr, 3)) = Application.Transpose(b) .Range(.Cells(1, k + 1), .Cells(lLr, k + 1)) = Application.Transpose(a) End With Next k Application.ScreenUpdating = True End Sub |
|