dispatcher données de BDD sur classeur et onglet

[wifi7768]

Bonjour,

Je suis nouveau sur le forum et débutant en excel...
J'ai une BDD alimentée par un USF. Cette BDD comporte 8 colonnes, avec la première colonne "procéssus" et la 2eme colonne "sous-processus".
Je souhaiterais pouvoir apres avoir renseigné mon USF pour alimenter ma BDD, que les 2 premières colonnes soient riées dans un classeur X existant (en fonction du nom (4 possibilités) de la cellule de la 1ere colonne "processus" ) et dans un onglet existant, dans ce fameux classeur X , fonction du nom des cellules de la 2eme colonne (sous processus).
Merci de votre aide.

Je joins le code du formulaire pour remplir la BDD.
Le fichier excel est trop lourd pour être posté

Private Sub ajout_donnes_Click()

    
    Worksheets("donnees").Visible = True 'afficher la feuille "donnees"
    Worksheets("interface").Visible = False 'afficher la feuille "interface"
    Worksheets("documents").Visible = False 'masquer la feuille "document""
 
    Unload Me 'Fermer la boite de dialogue
    ajoutdon.Show 'afficher la boite de dialogue "ajoutdon"
    
End Sub

Private Sub ajouter_doc_Click()


 Worksheets("documents").Unprotect ("a") 'verrouiller la feuille "documents"


'on vérifie si la zone de texte n'est pas vide
    If titre.Text = "" And Not (combo_domaine = "") Then
        MsgBox ("Entrer le nom du document")
        Exit Sub
    End If
    
    
    If combo_domaine.Text = "" And Not (titre = "") Then
        MsgBox ("Entrer le domaine du document")
        Exit Sub
    End If

    If combo_domaine.Text = "" And titre.Text = "" Then
        MsgBox ("Entrer le domaine et le titre du document")
        Exit Sub
    End If



'On vérifie si le domaine n'existe pas

For i = 1 To (Worksheets("documents").Cells(1, 1))
If titre = Worksheets("documents").Cells(i, 4) Then
     MsgBox ("ce documents existe déjà")
        Exit Sub
    End If

Next



' recherche de la ligne vide
    ligne = 2
    Do While Cells(ligne, 4).Text <> ""
        ligne = ligne + 1
    Loop
      Cells(ligne, 2) = combo_domaine 'ajout du nom du domaine
      Cells(ligne, 3) = combo_SD 'ajout du nom du sous-domaine
      Cells(ligne, 4) = titre 'ajout du nom du document
      Cells(ligne, 5) = auteur1 'ajout du nom de l'auteur
      Cells(ligne, 6) = auteur2 'ajout du nom de l'auteur2
      Cells(ligne, 7) = ncbox4 'ajout de la date
      Cells(ligne, 8) = TextBox1 'ajout de la date
      Cells(ligne, 9) = biblio 'ajout de la bibliographie
      Cells(ligne, 10) = ncBox5 'ajout de la date revision
      
      Worksheets("documents").Rows(ligne).Select
      Selection.EntireRow.Hidden = False
      
    Worksheets("documents").Protect ("a") 'verrouiller la feuille "documents"

MsgBox ("le nouveau document a bien été ajouté à la liste")

'Vider les zone de saisie
combo_domaine = ""
combo_SD = ""
titre = ""
auteur1 = ""
auteur2 = ""

End Sub
Private Sub annuler_Click() 'retourner à l'acceuil de la base de données
    
    Worksheets("donnees").Visible = False 'masquer la feuille "donnees"
    Worksheets("interface").Visible = True 'afficher la feuille "interface"
    Worksheets("documents").Visible = False 'masquer la feuille "document""
    Unload Me 'Fermer la boite de dialogue
    
End Sub

Private Sub auteur1_Change()

End Sub

Private Sub auteur2_Change()

End Sub

Private Sub combo_domaine_Change()
If combo_domaine.Value = "" Then
        combo_SD.RowSource = ""
        combo_SD.Value = ""
    Else
        Select Case combo_domaine.ListIndex
            Case 0
                combo_SD.RowSource = "Liste!B1:B6"
            Case 1
                combo_SD.RowSource = "Liste!C1:C6"
            Case 2
                combo_SD.RowSource = "Liste!D1:D10"
            Case 3
                combo_SD.RowSource = "Liste!E1:E7"
        End Select
    End If
End Sub


Private Sub combo_SD_Change()

End Sub

Private Sub Label6_Click()

End Sub

Private Sub Label8_Click()

End Sub

Private Sub Label9_Click()

End Sub

'Afficher date d'enregistrement dans formulaire
Sub Affich_date()
ncbox4.Value = Format(DateSerial(spban.Value, spbmois.Value, spbjour.Value), "dd/mm/yyyy")
End Sub


Private Sub ncbox4_Change()

End Sub

Private Sub spban_Change()
    Affich_date
End Sub
Private Sub spbjour_Change()
    If spbjour.Value = 0 Then
        spbjour.Value = 31
    ElseIf spbjour.Value = 32 Then
        spbjour.Value = 1
    End If
    Affich_date
End Sub

Private Sub spbmois_Change()
    If spbmois.Value = 0 Then
        spbmois.Value = 12
    ElseIf spbmois.Value = 13 Then
        spbmois.Value = 1
    End If
    Affich_date
End Sub
'Afficher date d'enregistrement dans formulaire
Sub Affich_date1()
ncBox5.Value = Format(DateSerial(spban1.Value, spbmois1.Value, spbjour1.Value), "dd/mm/yyyy")
End Sub


Private Sub ncbox5_Change()

End Sub

Private Sub spban1_Change()
    Affich_date1
End Sub
Private Sub spbjour1_Change()
    If spbjour1.Value = 0 Then
        spbjour1.Value = 31
    ElseIf spbjour1.Value = 32 Then
        spbjour1.Value = 1
    End If
    Affich_date1
End Sub

Private Sub spbmois1_Change()
    If spbmois1.Value = 0 Then
        spbmois1.Value = 12
    ElseIf spbmois1.Value = 13 Then
        spbmois1.Value = 1
    End If
    Affich_date1
End Sub
Private Sub TextBox1_Change()

End Sub

Private Sub titre_Change()

End Sub

Private Sub UserForm_Activate()

    For i = 2 To (Worksheets("donnees").Cells(2, 1) + 1) 'remplir la combobox domaine
        combo_domaine.AddItem Worksheets("donnees").Cells(i, 2)
    Next
    
    For i = 2 To (Worksheets("donnees").Cells(2, 4) + 1) 'remplir la combobox sous-domaine
        combo_SD.AddItem Worksheets("donnees").Cells(i, 5)
    Next

    For i = 2 To (Worksheets("donnees").Cells(2, 7) + 1) 'remplir les comboboxs auteur
        auteur1.AddItem Worksheets("donnees").Cells(i, 8)
        auteur2.AddItem Worksheets("donnees").Cells(i, 8)
    Next
    
    
    
biblio.AddItem "VERSION" 'ajouter la valeur "X" à la liste de choix

End Sub

A bientôt.

 

[Staple1600]

Re : dispatcher données de BDD sur classeur et onglet

Bonsoir à tous

wifi7768
L'extension de tes classeurs est bien *.xls (et non pas *.xlsx ou *.xlsm vu que tu es en Excel2007) ?

 

[ChTi160]

Re : dispatcher données de BDD sur classeur et onglet

Bonsoir wifi7768
Bonsoir JM
Bonsoir le Fil
Bonsoir le Forum
le problème ne vient il pas d'une erreur de report dans la Macro
car je lis ci dessous : Set DWbk = Workbooks.Open ( etc etc )

Set DWbk = Workbooks.Open(Chemin & ACOPIER.Range("A1").Text & ".xls")
ACOPIER.Copy DWbk.Sheets(1).[A65536].End(xlUp)(2)

Et la :Set DWbk = Workbooks(etc etc )
[highlight=Vba]Set DWbk = Workbooks(combo_domaine & ".xls")
ACOPIER.Copy DWbk.Sheets(CStr(combo_SD)).[A65536].End(xlUp)(2)[/code]
en espérant avoir fait avancer le chimilimblick
Bonne fin de Soirée
Amicalement
Jean Marie

 

[Staple1600]

Re : dispatcher données de BDD sur classeur et onglet

Bonsoir JM

Je ne saurai te dire (les codes que j'ai soumis fonctionnent sur mon PC)
Et comme on ne connait pas l'entièreté du code VBA utilisé par wifi7768

wifi7768:
Joins nous ton dernier fichier de test en l'état avec le code VBA que tu testes actuellement.
On devrait y voir plus clair.

 

[ChTi160]

Re : dispatcher données de BDD sur classeur et onglet

Salut JM
Ok on attend lol
Bonne fin de Soirée
Amicalement
Jean Marie

 

[wifi7768]

Re : dispatcher données de BDD sur classeur et onglet

Bonsoir à Tous
Bonsoir Staple 1600, Bonsoir Chti 160

J'utilise bien des extensions .xls

Je joins le fichier utilisé (calsseur1) avec le code VBA, et le classeur mangament pour exemple dans lequel je voudrais une copie des documents liés au processus management.

Merci.

 

[Staple1600]

Re : dispatcher données de BDD sur classeur et onglet

Re


Pas étonnant que cela bug
Voici ton code
'recopie bis (test ok)
dligneCA = .Cells(Application.Rows.Count, 1).End(xlUp).Row
Set ACOPIER = .Rows(dligneCA).SpecialCells(xlCellTypeConstants)
End With
Offset DWbk = Workbooks(combo_domaine & ".xls")
ACOPIER.Copy DWbk.Sheets(CStr(combo_SD)).[A65536].End(xlUp)(2)

Que vient faire Offset ici ???
T'as perdu tes lunettes
C'est Set et pas Offset

 

[wifi7768]

Re : dispatcher données de BDD sur classeur et onglet

Bonjour à Tous,

Bonjour Staple 1600

J'ai modifié le VBA suite à ton message.
Mais j'obtiens toujours le message : "erreur d'execution 9 l'indice n'appartient pas à la séléction
Set DWbk = Workbooks(combo_domaine & ".xls") surligné en jaune."


Je joins le fichier modifié.

Merci.

Bien cordialement,

 

[ChTi160]

Re : dispatcher données de BDD sur classeur et onglet

Bonjour wifi7768
Bonjour JM
Bonjour le Fil , Le Forum

ci dessous ce que j'ai modifié et qui a l'air de fonctionner (les classeurs étant dans le même répertoire)
j' ai aussi renommé certains objets du Userform

Private Sub CommandButton1_Click()
Dim i&, dligne&, dligneCA&, ctrl As Control
Dim Nom_S_Processus As String
Dim WkB_Source As Workbook

Dim nomdoc$, DWbk As Workbook, Verif As Range, ACOPIER As Range

Application.ScreenUpdating = False

    Set WkB_Source = ThisWorkbook 'on affecte le classeur a la variable
chemin = ThisWorkbook.Path & "\" 'on récupère le chemin du fichier

'on vérifie si la zone de texte n'est pas vide
   If titre.Text = "" And Not (combo_domaine = "") Then
        MsgBox ("Entrer le nom du document")
        Exit Sub
    End If
    If combo_domaine.Text = "" And Not (titre = "") Then
        MsgBox ("Entrer le domaine du document")
        Exit Sub
    End If
    If combo_domaine.Text = "" And titre.Text = "" Then
        MsgBox ("Entrer le domaine et le titre du document")
        Exit Sub
    End If
'On vérifie si le domaine n'existe pas
nomdoc = titre.Text
With WkB_Source
With .Worksheets("documents")
  
       .Unprotect ("a") 'On déverrouiller la feuille "documents"
Set Verif = .Columns("H:H").Find(What:=nomdoc, _
After:=.[H2], LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not Verif Is Nothing Then
MsgBox "Ce document existe déjà"
Exit Sub
End If
dligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'on détermine la première ligne vide en partant du bas

For Each ctrl In Me.Controls 'pour chaque control du Userform
    If ctrl.Tag Like "col*" Then 'si le tag du control correspond a
          .Cells(dligne, CLng(Mid(ctrl.Tag, 4, 2))) = ctrl.Value 'on colle la valeur dans la cellule
    End If
Next ctrl
Set ACOPIER = .Rows(dligne).SpecialCells(xlCellTypeConstants)
   End With
End With
    
  Set DWbk = Workbooks.Open(chemin & combo_domaine & ".xls") 'on ouvre le Classeur
With DWbk 'avec ce classeur
  
ACOPIER.Copy .Sheets(CStr(CmbB_S_Processus)).[A65536].End(xlUp)(2) 'on colle la ligne du classeur source a la première ligne vide en partant du bas de la Colonne 1(A) 
   .Close True 'on ferme le classeur Cible
End With
Application.ScreenUpdating = True
End Sub

a tester et adapter éventuellement
Bonne Journée
Amicalement
Jean Marie

 

[wifi7768]

Re : dispatcher données de BDD sur classeur et onglet

Bonsoir A Tous

Bonsoir Staple 1600, Bonsoir Chti160

Merci , cela fonctionne. SUPER !
En revanche si je ne renseigne pas tous les champs sur le userform (autres que ceux obligatoires) , la ligne est recopiée dans le dossier adéquat, mais sans laisser de colonne vides.
Comment pourrait-on s'assurer que les données qui soient dans la colonne J par exemple, seront bien recopiées dans le fichier de destination dans la colonne J, et cela meme si il manque dans des données en colonnes E et F par exemple ?

Merci encore.

Bonne soirée

 

[Staple1600]

Re : dispatcher données de BDD sur classeur et onglet

Bonsoir à tous

Chti160
On est bien d'accord que le code de ce message fonctionnait
https://www.excel-downloads.com/threads/dispatcher-donnees-de-bdd-sur-classeur-et-onglet.196323/
Et que tes modifs ne corrigent pas celui-ci ?
(A vue de nez, tu as ajouté les commentaires (merci et le Close True
J'en oublie pas ?

Donc wifi7768, tu devais avoir des erreurs de syntaxe dans tes codes
Va falloir redoubler en vigilance et en concentration , petit sacripant

 

[wifi7768]

Re : dispatcher données de BDD sur classeur et onglet

Re,

Oui je suis d'accord Staple 1600 que le code que tu mentionnes marche parfaitement, en fait c'éatit un tag que je n'avais pas modifié...Désolé...

Merci encore.

Bonne soirée

 

[ChTi160]

Re : dispatcher données de BDD sur classeur et onglet

Bonsoir Le Fil

Non JM je n'ai rien fait de spécial Lol
pour ce qui est du report des données, il peut s'agir de cette Ligne

Set ACOPIER =.Rows(dligne).SpecialCells(xlCellTypeConstants)

à tester demain Lol
Bonne nuit
Amicalement
Jean marie

 

[wifi7768]

Re : dispatcher données de BDD sur classeur et onglet

Bonjour,

Merci à tous,

Je pense essayer avec

Set ACOPIER =.Rows(dligne).SpecialCells(xlCellTypeVisible)

Bonne journée

 

[ChTi160]

Re : dispatcher données de BDD sur classeur et onglet

Bonjour wifi7768
Bonjour JM ,Le Forum

ci dessous le Code modifié qui semble répondre à la demande

Private Sub CommandButton1_Click()
Dim i&, dligne&, dligneCA&, ctrl As Control
Dim Nom_S_Processus As String
Dim WkB_Source As Workbook

Dim nomdoc$, DWbk As Workbook, Verif As Range, ACOPIER As Range
Dim Tab_Recup() As Variant
Dim x As Byte
Dim Str_DWbk_Name As String
Dim Str_wSht_Name As String
x = 0
Application.ScreenUpdating = False
    Set WkB_Source = ThisWorkbook
            Chemin = ThisWorkbook.Path & "\" ' 'on récupére le chemin
'on vérifie si la zone de texte n'est pas vide
   If UserForm1.titre.Text = "" And Not (UserForm1.combo_domaine = "") Then
        MsgBox ("Entrer le nom du document")
        Exit Sub
    End If
    If UserForm1.combo_domaine.Text = "" And Not (UserForm1.titre = "") Then
        MsgBox ("Entrer le domaine du document")
        Exit Sub
    End If
    If UserForm1.combo_domaine.Text = "" And UserForm1.titre.Text = "" Then
        MsgBox ("Entrer le domaine et le titre du document")
        Exit Sub
    End If
'On vérifie si le domaine n'existe pas
nomdoc = UserForm1.titre.Text ' récupére lea valeur
With WkB_Source 'avec le Classeur
With .Worksheets("documents") 'avec la feuille"documents" de ce classeur
               .Unprotect ("a") 'déverrouiller la feuille "documents"
      dligne = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'on determine la ligne ou l'on va coller les donnees
      'ci dessous on verifie si existe deja
   Set Verif = .Range(.Cells(1, 8), .Cells(dligne, 8)).Find(What:=nomdoc, _
After:=.Cells(1, 8), LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not Verif Is Nothing Then 'si oui message existe
MsgBox "Ce document existe déjà" 'message
Exit Sub 'on quitte ensuite
End If

'si n'existe pas
Str_DWbk_Name = UserForm1.combo_domaine.Value 'on récupére le nom du Dossier cible
Str_wSht_Name = UserForm1.CmbB_S_Processus    'on récupére le nom de la feuille Cible

For Each ctrl In Me.Controls 'pour chaque control du userform
    If ctrl.Tag <> "" Then 'si la propriété Tag n'est pas vide
             
          ReDim Preserve Tab_Recup(x) 'on redimmensionne le tableau
              Tab_Recup(x) = ctrl.Value 'on y récupére la valeur du control
                 x = x + 1 'on incremente
           
                  ctrl.Value = "" 'on efface le control
    End If
Next ctrl
        .Cells(dligne, 1).Resize(1, UBound(Tab_Recup, 1) + 1) = Tab_Recup 'on colle les donnees du tableau dans la feuille "documents"
   End With
End With
   
 Set DWbk = Workbooks.Open(Chemin & Str_DWbk_Name & ".xls") 'on ouvre le Classeur cible
 
With DWbk
  With .Worksheets(Str_wSht_Name) 'on determine la feuille Cible
  
       .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(1, UBound(Tab_Recup, 1) + 1) = Tab_Recup 'on colle les donnees du tableau
  
  Erase Tab_Recup 'on vide le tableau
  End With
     .Close True 'on ferme le classeur
  Set DWbk = Nothing  'on vide la variable
  Set WkB_Source = Nothing  'on vide la variable
  Str_DWbk_Name = ""  'on vide la variable
  Str_wSht_Name = ""  'on vide la variable
End With
Application.ScreenUpdating = True
End Sub

si besoin ne pas hésiter Lol
Bonne Journée
Amicalement
Jean Marie

 

[wifi7768]

Re : dispatcher données de BDD sur classeur et onglet

Bondoir à Tous,
Bonsoir Staple 1600
Bonsoir ChTI160

Merci pour ce code.
j'ai du mettre en commentaire cette partie

ctrl.Value = "" 'on efface le contro

car sinon les données en colonne 2 n'étaient pas recopiées (sous processus) ?

Serait il possible que les lignes copiées dans la feuille "documents" et les lignes recopiées dans les divers classeurs puissent être incrémentées à partir de la colonne B, et non à partir dans la colonne A ?

Merci d'avance.

Bonne soirée.