apply macro over multiple sheets

user_18648884 0
Viewed 63

i am verry new here i have a macro that coppy a row (45) and insert it a couple of times below that row(45)

i have assigned this macro to a button now i'm looking for a way that if i click that button the macro apply's this command to all sheets

here is the macro i am using now

Sub finaleRijenToevoegenVoorschotFactuur()
    Dim xCount As Integer
LableNumber:
    xCount = Application.InputBox("Aantal rijen", "VERKOPEN DIE HANDEL", , , , , , 1)
    If xCount < 1 Then
        MsgBox "the entered number of rows is error, please enter again", vbInformation, "testing"
        GoTo LableNumber
    End If
    Range("A42").Select
    ActiveCell.EntireRow.Copy
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(xCount, 0)).EntireRow.Insert Shift:=xlDown
    Application.CutCopyMode = False
End Sub
vba excel
1 Answers

Copy/Insert Multiple Rows in Multiple Worksheets

Option Explicit

Sub finaleRijenToevoegenVoorschotFactuur()
    
    Const CopyRow As Long = 4
    
    Dim xCount As Variant
    Do
        xCount = Application.InputBox("Aantal rijen", "VERKOPEN DIE HANDEL", , , , , , 1)
        If TypeName(xCount) = "Boolean" Then
            MsgBox "You canceled.", vbExclamation
            Exit Sub
        End If
        If xCount < 1 Then
            MsgBox "the entered number of rows is to small, please enter again", vbCritical, "testing"
        Else
            Exit Do
        End If
    Loop
    
    Dim ash As Object: Set ash = ActiveSheet
    Dim wb As Workbook: Set wb = ash.Parent
    
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Dim wsCount As Long
    
    For Each ws In wb.Worksheets
        wsCount = wsCount + 1
        With ws.Rows(CopyRow)
            .Copy
            .Offset(1).Resize(xCount).Insert xlShiftDown, xlFormatFromLeftOrAbove
        End With
    Next ws
    
    Dim MsgString As String
    MsgString = "Worksheets processed: " & wsCount
    
    If wsCount > 0 Then
        Application.CutCopyMode = False
        ash.Select
        MsgString = MsgString & vbLf & "Rows inserted: " & xCount
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox MsgString, vbInformation
    
End Sub
user_98140690
Related