Hallo allerseits,

Ich habe folgendes Problem:
Mein Makro kopiert ausgewählte Tabellenblätter aus der aktiven Mappe und fügt diese in einem Blatt zusammen und speichert das neue Blatt in einer neuen Mappe. 
In der aktiven Mappe haben alle Blätter in der Zelle A1 eine fortlaufende Nummerierung. Nun würde ich gerne die Nummerierung im zusammengefügten Blatt fortlaufend beibehalten, auch wenn mal ein Blatt nicht mitkopiert wurde.

Ich wäre sehr froh, wenn Ihr mir hierbei helfen könntet.

Hier mal mein bisheriges Makro:

Private Sub CmdSelect2_Click()
  
Dim intSh As Integer
Dim Msg As String
Dim wks As Worksheet
Dim strLC As String
Dim Rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim i As Integer
Dim r As Object, LR As Long
Dim TBName As String
Dim WBName As String
Dim strPfad As String


Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set wks = Worksheets.Add
wks.Name = "Completed Checklist"
If Me.ListBox2.ListCount = 0 Then Exit Sub
For intSh = 0 To Me.ListBox2.ListCount - 1
  If Me.ListBox2.Selected(intSh) Then Msg = Msg & Me.ListBox2.List(intSh) & vbCr
Next
Unload Me

          
For i = 3 To wb.Worksheets.Count
  If InStr(Msg, wb.Sheets(i).Name) > 0 Then
    With wb.Sheets(i).UsedRange
      LR = wks.Cells(Rows.Count, "A").End(xlUp).Row + 1
      strLC = .Cells(.Rows.Count, .Columns.Count).Address
      Set Rng = .Range("A1:" & strLC)
      Rng.Copy Destination:=wks.Cells(LR, 1)
    End With
  End If
Next i
wks.Select
Columns("A:A").WrapText = False
Columns("A:A").ColumnWidth = 8
Columns("A:A").Rows.AutoFit
Columns("B:B").WrapText = False
Columns("B:B").ColumnWidth = 10
Columns("B:B").Rows.AutoFit
Columns("C:C").WrapText = True
Columns("C:C").ColumnWidth = 74
Columns("C:C").Rows.AutoFit
Columns("D:D").WrapText = True
Columns("D:D").ColumnWidth = 8
Columns("D:D").Rows.AutoFit
Columns("E:E").WrapText = True
Columns("E:E").ColumnWidth = 8
Columns("E:E").Rows.AutoFit
Columns("F:F").WrapText = True
Columns("F:F").ColumnWidth = 8
Columns("F:F").Rows.AutoFit
Columns("G:G").WrapText = True
Columns("G:G").ColumnWidth = 34
Columns("G:G").Rows.AutoFit

For Each r In ActiveSheet.UsedRange.Rows
   r.EntireRow.AutoFit
   If r.RowHeight < 25 Then r.RowHeight = 25
Next
    
With ActiveSheet.PageSetup
    .Orientation = xlLandscape
    .Zoom = 85
    .FitToPagesWide = 1
    .FitToPagesTall = 1
End With


TBName = ActiveSheet.Name
  
'** Ask for Filename
WBName = InputBox("Under which name would you like to " & _
"save your checklist?" & vbLf & vbLf & _
"Please enter filename:")
If WBName = "" Then
Application.DisplayAlerts = False
Worksheets(TBName).Delete
Application.DisplayAlerts = True
Exit Sub
End If


'** Move Sheet
Worksheets(TBName).Move

strPfad = Environ("UserProfile") & "\Desktop\"

'** Create new Book, save on desktop and close
ActiveWorkbook.SaveAs Filename:=strPfad & WBName, FileFormat _
        :=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False
ActiveWorkbook.Close
MsgBox "Your Checklist has been saved on your Desktop!"

Exit Sub
  
'** Errorhandling
ErrorMessage:
MsgBox "An Error Occurred!"

Application.ScreenUpdating = True

End Sub

Vielen Dank im Voraus!