Indsæt rækker og kopier værdier

Går ud fra at de 7 rækker skal indsættes under rækken med kundenr.
Hvilke og hvor skal teksterne placeres?

Denne VBA-kode indsætter rækkerne:

Sub Insert7Rows()

    Dim t As Long

    For t = Range("A10000").End(xlUp).Row To 3 Step -1
   
        Rows(t & ":" & t + 6).EntireRow.Insert
   
    Next t

End Sub

Denne kode kan udvides til også at indsætte de syv forskellige tekster - forudsat at det er de samme syv tekster for hvert kundenummer.


Mvh Max

Der skal indsættes 7 rækker pr kunde med den samme tekst. Kan ovenstående bruges?

Hvordan tilføjer jeg teksten Max?

Her er en "quick-and-dirty"-løsning, hvor teksterne indsættes i kolonne A. Du kan selv tilpasse makroen, hvad angår kolonne og teksterne "Tekst 1" .... "Tekst 7".

Sub Insert7Rows()

    Dim t As Long

    With ActiveSheet
   
        For t = .Range("A10000").End(xlUp).Row To 2 Step -1
       
            If t > 2 Then
           
                .Rows(t & ":" & t + 6).EntireRow.Insert
         
                .Range("A" & t + 8) = "Tekst 1"
                .Range("A" & t + 9) = "Tekst 2"
                .Range("A" & t + 10) = "Tekst 3"
                .Range("A" & t + 11) = "Tekst 4"
                .Range("A" & t + 12) = "Tekst 5"
                .Range("A" & t + 13) = "Tekst 6"
                .Range("A" & t + 14) = "Tekst 7"
               
            Else
           
                .Range("A" & t + 1) = "Tekst 1"
                .Range("A" & t + 2) = "Tekst 2"
                .Range("A" & t + 3) = "Tekst 3"
                .Range("A" & t + 4) = "Tekst 4"
                .Range("A" & t + 5) = "Tekst 5"
                .Range("A" & t + 6) = "Tekst 6"
                .Range("A" & t + 7) = "Tekst 7"
               
            End If
       
        Next t
       
    End With

End Sub

Håber du får det til at virke :-)


Mvh Max

Tusind tak for hjælpen