sobota, 24 listopada 2012

Dodawanie wierszy w całym arkuszu

Dawno temu przegapiłem prośbę o skrypt:

"Dodanie tylu wierszy poniżej wiersza A, ile wskazywała by wartość np w komórce A1 i tak przez cały arkusz?"

excel nowe wiersze


Tworzymy skrypt VBA:
Option Explicit

Sub DodajWierszePoniżej()

    Dim i, j As Integer
    Range("A1").Select
    
    ' szukamy od ostatniego wiersza i jedziemy do samej gory
    For i = Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
       
       'jesli komorka z kolumny A nie jest pusta
       If (Not IsNull(Cells(i, 1))) Then
        
          'jesli komorka z kolumny A jest numeryczna
          If (IsNumeric(Cells(i, 1))) Then
          
          'dodaj po niej tyle wierszy ile jest w kolumnie A
            For j = 1 To Cells(i, 1).Value

               'dodaj wiersze nad nastepnym
               Cells(i + 1, 1).EntireRow.Insert

            Next j
          
          End If
          
        End If
        
    Next i

End Sub

A po jego uruchomieniu otrzymujemy (ALT + F8)

excel nowe wiersze


1 komentarz:

  1. Witam.
    Czy jest możliwość aby makro wraz z dodawaniem wierszy kopiowało wartość z kolumny drugiej w nowo powstałe puste komórki poniżej?

    OdpowiedzUsuń