génération automatique de worksheets

Question

Bonjour, 

je souhaite g&#233;n&#233;rer grace &#224; une macro VBA autant de worksheets que j'ai de noms dans une table saisie dans une feuille Excel: j'ai cr&#233;&#233; une table (10 lignes, 3 colonnes) dans une feuille appel&#233;e "sheet1" et je souhaite maintenant &#233;crire une macro qui me permettra de g&#233;n&#233;rer 10 nouvelles feuilles dans un nouveau workbook. Le nom &#224; donner au nouveau workbook se trouve dans la cellule A1 de la feuille "sheet1" et le nom &#224; donner &#224; chaque feuille se trouve dans la table cr&#233;e&#233; dans "sheet1", &#224; l'intersection de chaque ligne et de la colonne n&#176;1. Le contenus de la colonne 2 et 3 devront &#234;tre recopi&#233;s dans chaque feuille corresponmdante, dans les cellules A1 et A2.
Je commence par o&#249; ??? 
Merci de votre aide

jsem2k1 · Answer

The J

Salut monial 
d&#233;sol&#233; pour les fautes d'ortographe

tu peux proc&#233;d&#233; comme suis
le code n'est pas obtimiser mais devrait marcher 
Bonne chance

'ici j'ai ins&#233;r&#233; un bouton dans la feuille sheet1


Dim strnomfeuille(10) As String
Dim valeur(10) As String
Dim valeur2(10) As String
Dim w As Workbook
Dim a As Integer
Dim i As Integer
Dim msg As Integer



Private Sub CommandButton1_Click()


'Ici le range a4:a13 repr&#233;sante ton tableau
Range("A4:A13").Select


'On v&#233;rifi s'il n'y a pas de carat&#232;re ind&#233;sirable
a = 0
For Each cell In Selection
    
    For i = 1 To Len(cell.Value)
        If InStr(1, "/#*[]~?", Mid(cell.Value, i, 1)) = 0 Then
            a = a + 1
            strnomfeuille(i) = cell.Value
            valeur(i) = cell.Offset(0, 1).Value
            valeur2(i) = cell.Offset(0, 2).Value
        Else
            MsgBox "Carar&#232;re incongrue dans la cellule " & cell.Address, , "Erreur"
            Exit Sub
        End If
    
    Next i
    
    
Next


'On v&#233;rifie s'il ny as pas de classeur ouver avec le meme nom


For Each w In Workbooks
    
    If w.Name = [A1].Value & ".xls" Then
         msg = MsgBox("Le fichier " & [A1].Value & ".xls" & " est d&#233;ja ouvert." & _
        vbNewLine & "Voulez vous le modifier?", vbQuestion + vbDefaultButton1 + vbYesNo, _
        "Erreur")
        
        If msg = vbYes Then
            Call ramplacer([A1].Value & ".xls")
            Exit Sub
        Else
            Exit Sub
        End If
    
    End If
    
Next


'On cr&#233;e le classeur d&#233;sir&#233;


Workbooks.Add.SaveAs [A1].Value



'On cr&#233;e les feuille d&#233;sir&#233;


For i = 1 To 10
    Sheets.Add
    With ActiveSheet
        .Name = strnomfeuille(i)
        .[A1].Value = valeur(i)
        .[A2].Value = valeur2(i)
    End With


Next i



End Sub


Sub ramplacer(nom As String)


Workbooks(nom).Activate


For Each Sheet In Worksheets
    For i = 1 To 10
        If Sheet.Name = strnomfeuille(i) Then
            strnomfeuille(i) = "["
            With Sheet
                .[A1].Value = valeur(i)
                .[A2].Value = valeur2(i)
            End With
        End If
    Next i
Next


For i = 1 To 10
    If strnomfeuille(i) <> "[" Then
        Sheets.Add
        With ActiveSheet
            .Name = strnomfeuille(i)
            .[A1].Value = valeur(i)
            .[A2].Value = valeur2(i)
        End With
    End If
Next i


End Sub

Génération automatique de worksheets

1 réponse

Discussions similaires