Mehrere Blatt erstellen wie in coloumn A genannt, und kopieren Sie Zeilen in ihnen mit Regeln

Question

Ich möchte:

• erstellen und Titel mehrere Blätter wie in Spalte A aufgeführt sind;
• Kopieren so oft wie in Spalte B Zeile 3 und 4 von Sheet_Model zu jedem neu erstellten Blatt

möglich, dass in Excel zu tun ist, aufgelistet ?? Danke !!

Answer 1

http://www.excelforum.com/showthread.php?t=1138853

danke

Sub ManySheets() 
    Dim SourceSheet As Worksheet 
    Dim DestinationSheet As Worksheet 
    Dim SheetNamesRange As Range 
    Dim oneSheetNameRow As Range 
    Dim variableDataRange As Range, fixedDataRange As Range, oneDataRow As Range 

    Set SourceSheet = ThisWorkbook.Sheets("Sheet_Model") 
    With SourceSheet 
     Set fixedDataRange = .Range("A1:C2") 
     Set variableDataRange = Range(.Range("C3"), .Cells(Rows.Count, 1).End(xlUp)) 
    End With 

    With ThisWorkbook.Sheets("Sheet_0") 
     Set SheetNamesRange = Range(.Cells(1, 2), .Cells(Rows.Count, 1).End(xlUp)) 
    End With 

    For Each oneSheetNameRow In SheetNamesRange.Rows 
     On Error GoTo MakeNewSheet 
     With ThisWorkbook.Sheets(oneSheetNameRow.Cells(1, 1).Value) 

      .Range("A1").CurrentRegion.Clear 

      SourceSheet.Range("A1:c2").Copy Destination:=.Cells(1, 1) 

      If Val(CStr(oneSheetNameRow.Cells(1, 2).Value)) > 0 Then 
       For Each oneDataRow In variableDataRange.Rows 
        oneDataRow.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(oneSheetNameRow.Cells(1, 2)) 
       Next oneDataRow 
      End If 

     End With 
     On Error GoTo 0 
    Next oneSheetNameRow 
Exit Sub 
MakeNewSheet: 
    If Err = 9 Then 
     With ThisWorkbook 
      .Worksheets.Add(after:=.Sheets(.Sheets.Count)).Name = oneSheetNameRow.Cells(1, 1).Value 
     End With 
     Resume 
    Else 
     MsgBox Err & vbCr & Error 
    End If 
End Sub