Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос вставки пустых строк при условии, Вставка строк по заднанному условию
 
#1
15.04.2022 11:56:12
Здравствуйте!
Есть макрос который всатвляет строки при условии, но оно соблюденно не полностью.
Нужно в колонке соблюсти обязательный порядок который контролируется последними цифрами в строке (10→20→30), елси нет какого-то из трех значений значит оно должно быть замененно пустой строчкой (пусто→20→30; 10→пусто→30; 10→20→пусто; 10→пусто→пусто; пусто→20→пусто; пусто→пусто→30 и т.д)
Sub Insert_Rows()
   Dim yy As Long
   Dim arr As Variant
   yy = Cells(Rows.Count, 1).End(xlUp).Row
   If yy = 1 Then Exit Sub
   arr = Range(Cells(1, 1), Cells(yy, 1))
   
   Dim Application_Calculation As Long
   Application_Calculation = Application.Calculation
   Application.Calculation = xlCalculationManual
   
   For yy = UBound(arr, 1) To 2 Step -1
       If Right(arr(yy, 1), 2) = "20" Then
           Cells(yy + 1, 1).Resize(1).EntireRow.Insert
           With Cells(yy + 1, 1).Resize(1, 1)
               Cells(yy, 1).Resize(1, 2).Copy .Cells
               .ClearContents
           End With
       ElseIf Right(arr(yy, 1), 2) = "10" Then
           If Right(arr(yy - 1, 1), 2) = "30" Then
               Cells(yy + 1, 1).EntireRow.Insert
               yy = yy - 1
           End If
       End If
   Next
   
   Application.Calculation = Application_Calculation
End Sub
 
 
 
#2
15.04.2022 12:26:31
Код
Sub Insert_Rows()
   Dim yy As Long
   Dim arr As Variant
   yy = Cells(Rows.Count, 1).End(xlUp).Row
   If yy = 1 Then Exit Sub
   arr = Range(Cells(1, 1), Cells(yy, 1))
   
   Dim uu As Long
   Dim brr As Variant
   ReDim brr(1 To 4 * UBound(arr, 1), 1 To 1)
   uu = 1
   brr(uu, 1) = arr(1, 1)
   
   For yy = 2 To UBound(arr, 1)
        Select Case Right(arr(yy, 1), 2)
        Case "10"
            Select Case Right(arr(yy - 1, 1), 2)
            Case "10"
                uu = uu + 3
            Case "20"
                uu = uu + 2
            Case "30"
                uu = uu + 1
            Case Else
                uu = uu + 1
            End Select
        Case "20"
            Select Case Right(arr(yy - 1, 1), 2)
            Case "10"
                uu = uu + 1
            Case "20"
                uu = uu + 3
            Case "30"
                uu = uu + 2
            Case Else
                uu = uu + 1
            End Select
        Case "30"
            Select Case Right(arr(yy - 1, 1), 2)
            Case "10"
                uu = uu + 2
            Case "20"
                uu = uu + 1
            Case "30"
                uu = uu + 3
            Case Else
                uu = uu + 1
            End Select
        Case Else
            uu = uu + 1
        End Select
        brr(uu, 1) = arr(yy, 1)
   Next
   
   
   Cells(1, 2).Resize(UBound(brr, 1), 1) = brr
End Sub
 
 
 
#3
27.04.2022 12:07:08
Спасибо огромное, но как поправить что бы результат выводил не в соседнюю колонку а вставлял в текущей?
Изменено: Михаил Воинов - 27.05.2022 09:06:18
 
 
 
#4
27.04.2022 13:10:03
Код
Cells(1, 1).Resize(UBound(brr, 1), 1) = brr
 
 
 
#5
26.05.2022 18:10:47
Спасибо)
но почему данный код вставляет  строки только в одной колонке (первой), а не по всему файлу?
Изменено: Михаил Воинов - 27.05.2022 09:07:48
 
 
 
#6
27.05.2022 00:43:19
Код
Sub InsRows()
  Const p$ = "1231"
  Dim a, adr$, ads, c$, i&, o&, s$, r&, rg As Range, pr, cr, pc&, re
  a = [a1].CurrentRegion
  cr = Val(Right(a(1, 1), 2)) / 10
  For r = 2 To UBound(a)
    pr = cr: cr = Val(Right(a(r, 1), 2)) / 10: pc = pr & cr
    If InStr(p, pc) = 0 Then
      c = Replace(Replace(Replace(p, pr, ""), cr, ""), "1", "", 1, 1)
      s = s & "," & r & ":" & r + Len(c) - 1
    End If
  Next
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "(:)(\d+)(,)(\2)"
  re.Global = True:  s = Right(s, Len(s) - 1)
  If re.test(s) Then s = re.Replace(s, "$1$2 $4")
  ads = Split(s)
  For i = UBound(ads) To 0 Step -1
    Do While Len(ads(i)) > 255
      o = InStr(Right(ads(i), 255), ","): Range(Right(ads(i), 255 - o)).Insert
      ads(i) = Left(ads(i), Len(ads(i)) - 256 + o)
    Loop
    If Len(ads(i)) Then Range(ads(i)).Insert
  Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#7
27.05.2022 00:48:32
Михаил Воинов,  приветиде сообщение #5 в порядок: не цитата это, а сплошное безобразие.
Да и #3 не лучше. Зачем цитировать то, что цитировать не нужно?
 
 
 
#8
27.05.2022 09:10:40
Именно по этому и обратился на данный сайт, что бы самостоятельно обучиться это и понять что в что раньше было не известно!
Изменено: Михаил Воинов - 27.05.2022 09:10:59
 
 
 
#9
27.05.2022 09:12:44
Цитата
написал:
Михаил Воинов,  приветиде сообщение #5 в порядок: не цитата это, а сплошное безобразие.
Да и #3 не лучше. Зачем цитировать то, что цитировать не нужно?
Поправил.
Цитировал данные сообщения что бы не терять связи в переписке, что очень часто бывает когда много людей общаются в одной теме.
Но если здесь так не принято, то на будущее учту данную ошибку.
 
 
 
#10
27.05.2022 09:18:19
Цитата
написал:
Sub InsRows()  Const p$ = "1231"  Dim a, adr$, ads, c$, i&, o&, s$, r&, rg As Range, pr, cr, pc&, re  a = [a1].CurrentRegion  cr = Val(Right(a(1, 1), 2)) / 10  For r = 2 To UBound(a)    pr = cr: cr = Val(Right(a(r, 1), 2)) / 10: pc = pr & cr    If InStr(p, pc) = 0 Then      c = Replace(Replace(Replace(p, pr, ""), cr, ""), "1", "", 1, 1)      s = s & "," & r & ":" & r + Len© - 1    End If  Next  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "((\d+)(,)(\2)"  re.Global = True:  s = Right(s, Len(s) - 1)  If re.test(s) Then s = re.Replace(s, "$1$2 $4")  ads = Split(s)  For i = UBound(ads) To 0 Step -1    Do While Len(ads(i)) > 255      o = InStr(Right(ads(i), 255), ","): Range(Right(ads(i), 255 - o)).Insert      ads(i) = Left(ads(i), Len(ads(i)) - 256 + o)    Loop    If Len(ads(i)) Then Range(ads(i)).Insert  NextEnd Sub
Спасибо за код. Он действует на всём поле, но как мне написали в данной теме для чего я цитирую и ваш ответ где вы сказали о методах и проблемах о которых я не подозреваю, то данный макрос не выполняет необходимое условие.

Всё равно еще раз спасибо за уделенное время.
 
 
 
#11
27.05.2022 09:37:25
Цитата
Михаил Воинов написал:
то данный макрос не выполняет необходимое условие
вполне возможно, а если скажете какое, в каком месте, то я его могу поправить

и о "методах и проблемах" это стандартная подпись в каждом моем сообщения, она не обращена лично к вам, это обращение в космос если хотите.
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#12
27.05.2022 10:16:34
Цитата
написал:
Нужно в колонке соблюсти обязательный порядок который контролируется последними цифрами в строке (10→20→30), елси нет какого-то из трех значений значит оно должно быть замененно пустой строчкой (пусто→20→30; 10→пусто→30; 10→20→пусто; 10→пусто→пусто; пусто→20→пусто; пусто→пусто→30 и т.д)
Нужно в колонке соблюсти обязательный порядок который контролируется последними цифрами в строке (10→20→30), елси нет какого-то из трех значений значит оно должно быть замененно пустой строчкой (пусто→20→30; 10→пусто→30; 10→20→пусто; 10→пусто→пусто; пусто→20→пусто; пусто→пусто→30 и т.д)    

p.s. Вся тема програмирования для меня очень интересна, т.к. нет возможности пройти обычное обучение по програмированию то приходится изучать это самостоятельно т.к. голова требует развития и новой информации. Космос тоже очень интересная тема)
 
 
 
#13
27.05.2022 11:20:19
принцип понятен, согласно этому написал макрос
при каких данных где макрос вставил лишнюю строку или пропустил вставить пустую строку
пример таких данных есть?
пишете вот так было, вот так сделал макрос, вот в этой строке не правильно
Изменено: Ігор Гончаренко - 27.05.2022 11:20:36
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#14
27.05.2022 12:14:31
Цитата
написал:
но почему данный код вставляет  строки только в одной колонке (первой), а не по всему файлу?
Так по всему листу.
Код
Sub Insert_Rows()
   Dim yy As Long
   Dim arr As Variant
   yy = Cells(Rows.Count, 1).End(xlUp).Row
   If yy = 1 Then Exit Sub
   Dim xx As Long
   xx = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
   arr = Range(Cells(1, 1), Cells(yy, xx))
    
   Dim uu As Long
   Dim brr As Variant
   ReDim brr(1 To 4 * UBound(arr, 1), 1 To xx)
   uu = 1
    For xx = 1 To UBound(arr, 2)
        brr(uu, xx) = arr(1, xx)
    Next
    
   For yy = 2 To UBound(arr, 1)
        Select Case Right(arr(yy, 1), 2)
        Case "10"
            Select Case Right(arr(yy - 1, 1), 2)
            Case "10"
                uu = uu + 3
            Case "20"
                uu = uu + 2
            Case "30"
                uu = uu + 1
            Case Else
                uu = uu + 1
            End Select
        Case "20"
            Select Case Right(arr(yy - 1, 1), 2)
            Case "10"
                uu = uu + 1
            Case "20"
                uu = uu + 3
            Case "30"
                uu = uu + 2
            Case Else
                uu = uu + 1
            End Select
        Case "30"
            Select Case Right(arr(yy - 1, 1), 2)
            Case "10"
                uu = uu + 2
            Case "20"
                uu = uu + 1
            Case "30"
                uu = uu + 3
            Case Else
                uu = uu + 1
            End Select
        Case Else
            uu = uu + 1
        End Select
        For xx = 1 To UBound(arr, 2)
            brr(uu, xx) = arr(yy, xx)
        Next
   Next
    
   Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub
 
 
 
#15
02.06.2022 14:51:06
МатросНаЗебре, Спасибо большое!!!  
Очень сильно помогает в работе!
 
 
 
Страницы: 1
Наверх