Option Explicit
'v3
Sub Переброска()
Dim arr As Variant
arr = GetArr(ActiveSheet)
Dim orr As Variant
orr = GetOutArr(arr)
OutArr orr
End Sub
Sub OutArr(arr As Variant)
If Not IsEmpty(arr) Then
With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
.Columns(1).NumberFormat = "@"
.Columns(1).AutoFit
.Cells = arr
.Columns(1).AutoFit
End With
End If
End Sub
Function GetOutArr(arr As Variant) As Variant
Dim y As Long
Dim x As Integer
Dim maxX As Integer
Dim k As Integer
Dim crr As Variant
crr = arr
Dim brr As Variant
Dim b As Long
Dim i As Byte
Dim flag As Boolean
Dim fla2 As Boolean
For i = 0 To 1
For y = 5 To UBound(arr, 1)
Do
maxX = 3
flag = False
fla2 = False
For x = 3 To UBound(arr, 2) - 1 Step 2
If arr(y, maxX) - arr(y, maxX + 1) < arr(y, x) - arr(y, x + 1) Then
maxX = x
End If
If crr(y, x) = 0 Then If arr(y, x) < arr(y, x + 1) Then flag = True
If arr(y, x) > arr(y, x + 1) Then fla2 = True
Next
If fla2 = False Then Exit Do
If flag Then
x = maxX
If arr(y, x) > arr(y, x + 1) Then
For k = 3 To UBound(arr, 2) - 1 Step 2
If k <> x Then
If arr(y, x) > arr(y, x + 1) Then
If arr(y, k) < arr(y, k + 1) Then
If crr(y, k) = 0 Then
arr(y, x) = arr(y, x) - 1
arr(y, k) = arr(y, k) + 1
b = b + 1
If i = 0 Then
Else
brr(b, 1) = arr(y, 1)
brr(b, 2) = arr(y, 2)
brr(b, 3) = arr(2, x)
brr(b, 4) = arr(2, k)
brr(b, 5) = 1
End If
End If
End If
Else
Exit For
End If
End If
Next
End If
Else
Exit Do
End If
Loop
' For x = 3 To UBound(arr, 2) - 1 Step 2
' If True Then
' If arr(y, x) > arr(y, x + 1) Then
' For k = 3 To UBound(arr, 2) - 1 Step 2
' If k <> x Then
' If arr(y, x) > arr(y, x + 1) Then
' If arr(y, k) < arr(y, k + 1) Then
' If crr(y, k) = 0 Then
' arr(y, x) = arr(y, x) - 1
' arr(y, k) = arr(y, k) + 1
'
' b = b + 1
' If i = 0 Then
' Else
' brr(b, 1) = arr(y, 1)
' brr(b, 2) = arr(y, 2)
' brr(b, 3) = arr(2, x)
' brr(b, 4) = arr(2, k)
' brr(b, 5) = 1
' End If
' End If
' End If
' Else
' Exit For
' End If
' End If
' Next
' End If
' End If
' Next
Next
If i = 0 Then
If b = 0 Then
Exit For
Else
ReDim brr(1 To b, 1 To 5)
b = 0
arr = crr
End If
End If
Next i
GetOutArr = brr
End Function
Function GetArr(sh As Worksheet) As Variant
With sh
Dim y As Long
Dim x As Integer
y = .Cells(.Rows.Count, 1).End(xlUp).Row
x = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
GetArr = .Range(.Cells(1, 1), .Cells(y, x))
End With
End Function
|