Вопрос в названии: вставка строк некорректно срабатывает (в примере должен вставить 3, а вставил по 2, а иногда где-то 3, а где-то 2), если поставить фильтр (по 1 или 2 в примере) и применить её для всех видимых ячеек При этом пошаговый дэбаг пишет всё нормально, то есть, если руками делать тоже самое, то всё должно быть нормально Также, если выделять без фильтра рандомные ячейки и применять макрос, то всё норм Вспомогательные функции работают корректно
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
'====================================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
и что не корректного? все сработало так, как написано в макросе макрос обычно делает то, что в нем написано, а не то, что вы думали он будет делать поэтому, для начала: что за задачу пытаемся решить?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Ігор Гончаренко: и что не корректного? все сработало так, как написано в макросе
а вы попробуйте запустить и сравнить, прежде чем говорить - в который раз уже… Макрос должен вставить по 3 строки (например), а вставляет по 2, а иногда последние 2 раза - по три строки, а остальные - по 2. А если без фильтра, то нормально
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
так все-таки, что за задачу решаем? условия вашей задачи обьяснить можете? понимаю что это ваша задача и она совершенно очевидна вам но я это все вижу первый раз, мне можете обьяснить, что за задачу решаете, или процитируйте ту часть ваших ссообщений, где написаны условия этой задачи, может я невнимательно читал и пропустил их
вставка N строк перед или после каждой выделенной ячейки
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Sub InsSameRows()
Dim hm&, aft&, i&, r&, rg As Range, rw As Range, a
hm = [d1]: If hm = 0 Then Exit Sub
aft = IIf([g1], 0, 1): Set rg = Selection
Set rg = rg.SpecialCells(xlCellTypeVisible)
ReDim a(1 To rg.Count): i = 1
For Each rw In rg: a(i) = rw.Row: i = i + 1: Next
For r = UBound(a) To 1 Step -1
For i = 1 To hm
Rows(a(r) + aft).Insert xlShiftDown
Next
Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Ігор Гончаренко, ваш работает (вставка по одной строке) - спасибо, но мне хотелось бы разобраться со своим, а именно - почему при фильтре нельзя корректно вставлять по несколько строк
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Попробовал вставлять блоками через Resize.EntireRow - не помогло Получается, что работает только приём "в лоб", а именно вставлять по одной строке N раз — жаль Кто знает, как можно корректно вставлять строки блоками при включённом фильтре - поделитесь
Рабочая версия
Код
Option Explicit
'====================================================================================================================
Sub ВставитьСтроки()
Dim rng As Range, AC&
Dim arr, arrRows(), i&, n&, nIns&, nAft&
Set rng = Selection
nIns = [d1].Value2
nAft = [g1].Value2
Set arr = rng
If nIns = 1 Then
If Not RangeToRows(arr, nAft, True) Then Exit Sub
arr = Join(arr, ","): If Not Address_ToRange(arr) Then Exit Sub
arr.Select: MsgBox "Нажмите «Вставить строки на лист»", vbExclamation, "ДЕЙСТВИЕ ПОЛЬЗОВАТЕЛЯ"
Else
If Not RangeToRows(arr, nAft) Then Exit Sub
arrRows = arr: Sort_Array1x arrRows, 0, UBound(arrRows)
Application.ScreenUpdating = False: AC = Application.Calculation: Application.Calculation = xlCalculationManual
For i = UBound(arrRows) To 0 Step -1
For n = 1 To nIns
Rows(arrRows(i)).Insert
Next n
Next i
Application.ScreenUpdating = True: Application.Calculation = AC
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
'====================================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
vikttur: Снять фильтрацию, вставить блоками, вернуть фильтрацию
очевидно Однако проблем с запоминанием фильтра может быть куда больше - пусть тогда уж пока так
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄