Option Explicit
'====================================================================================================================
Sub ВставитьСтроки()
Dim rng As Range
Dim arr, arrRows(), i&, nIns&, nPos As Boolean
Set rng = Selection
nIns = [d1].Value2
nPos = [g1].Value2
Set arr = rng
If nIns = 1 Then ' эта часть работает нормально
If nPos Then i = 0 Else i = 1
If Not RangeToRows(arr, i, True) Then Exit Sub
arr = Join(arr, ","): If Not Address_ToRange(arr) Then Exit Sub
arr.Select: MsgBox "Нажмите «Вставить строки на лист»", vbExclamation, "ДЕЙСТВИЕ ПОЛЬЗОВАТЕЛЯ"
Else ' а вот с этой частью проблемы
If Not RangeToRows(arr) Then Exit Sub
arrRows = arr: Sort_Array1x arrRows, 0, UBound(arrRows)
Application.ScreenUpdating = False
If nPos Then
For i = UBound(arr) To 0 Step -1
Rows(arr(i) & ":" & arr(i) + nIns - 1).Insert
Debug.Print arr(i), arr(i), arr(i) & ":" & arr(i) + nIns-1
Next i
Else
For i = UBound(arr) To 0 Step -1
Rows(arr(i) + 1 & ":" & arr(i) + nIns).Insert
Debug.Print arr(i), arr(i) + 1 & ":" & arr(i) + nIns
Next i
End If
Application.ScreenUpdating = True
End If
End Sub
'====================================================================================================================
'====================================================================================================================
Function Address_ToRange(tmpAdr, Optional ByVal shName$ = "") As Boolean
Dim sh As Worksheet, gr As Range, p&
If TypeName(tmpAdr) <> "String" Then MsgBox "Строка адресов не передана!", vbCritical, "Address_ToRange": Exit Function
If Len(shName) Then Set sh = ActiveWorkbook.Worksheets(shName) Else Set sh = ActiveSheet
tmpAdr = Replace$(tmpAdr, "$", "")
If Len(tmpAdr) < 256 Then
Set tmpAdr = sh.Range(tmpAdr)
Address_ToRange = True: Exit Function
End If
p = InStrRev(Left$(tmpAdr, 255), ",")
Set gr = sh.Range(Left$(tmpAdr, p - 1))
tmpAdr = Mid$(tmpAdr, p + 1)
While Len(tmpAdr) > 255
p = InStrRev(Left$(tmpAdr, 255), ",")
Set gr = Union(gr, sh.Range(Left$(tmpAdr, p - 1)))
tmpAdr = Mid$(tmpAdr, p + 1)
Wend
Set tmpAdr = Union(gr, sh.Range(tmpAdr))
Address_ToRange = True
End Function
'====================================================================================================================
Function RangeToRows(ByRef tmpRng1col, Optional ByVal Offs&, Optional ByVal WithLetter As Boolean, Optional ByVal colLetter$ = "A") As Boolean
Dim dic As New Dictionary, cl As Range
Dim x, i&
If WithLetter Then
For Each cl In tmpRng1col
x = dic(colLetter & (cl.Row + Offs))
Next cl
Else
For Each cl In tmpRng1col
x = dic(cl.Row + Offs)
Next cl
End If
tmpRng1col = dic.Keys
RangeToRows = True
End Function
'====================================================================================================================
Sub Sort_Array1x(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then Sort_Array1x arr1x, l, j
If i < u Then Sort_Array1x arr1x, i, u
End Sub
'==================================================================================================================== |
