Problèmes d'export de données

[christophedb]

bonjour,

J'espère que vous pourrez m'aider,
j'ai un soucis sur l'exportation de certaines données d'une feuille
que je dois trier et ranger dans des cellules bien spécifique dans une autre feuille .

En fonction de données finales d'une colonne (G feuille 1)
j'aimerais rapatrier les différents poste occupés trié du plus petit numéro vers le plus grand (C feuille 1) dans la feuille 2 au poste correspondant indiqué. En récupérant pour chaque poste, le nom, prénom et n° ( doublons autorisé )
j'aimerais pouvoir créer une sous routine que je devrai inclure plus tard dans un userform.
cela devrait au mieux être automatique a chaque ouverture du classeur.
Je n'ai pas assez d'expérience en VB que pour créer le code.
la base de données finale que je dois trier comporte 210 personnes max et 29 postes différents
les personnes peuvent changer de poste et/ou être supprimée

j'ai essayé ce code qui fonctionne en partie,
il copie bien les cellules dans une autre feuille mais pas là ou je veux.

je crois que le problème vient de :

PLV.Copy
Set O2 = Sheets("feuil3")
Set DEST = O2.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)
DEST.PasteSpecial Paste:=xlValues, Transpose:=False
End Sub

Si je comprends bien, il copie la sélection faite en feuill3 cel A1,
j'aimerais comprendre comment faire pour moi même sélectionner les cellules ou je veux qu'il copie
Sinon dans la BD d'exemple la sélection se fait sur 3 colonnes adjacentes,
comment modifier le code pour sélectionner les colonnes voulues uniquement ??

voiçi le code et l'exemple
j'ai mis la procedure en ouverture du classeur dans 'thisWorkbook'

Option Explicit
Private Sub Workbook_Open()
Dim O1 As Object
Dim O2 As Object
Dim PL As Range
Dim PLV As Range
Dim DEST As Range
Set O1 = Sheets("Feuil1")
Set PL = O1.Range("A2:C" & O1.Cells(Application.Rows.Count, 1).End(xlUp).Row)
O1.Range("A1").AutoFilter Field:=7, Criteria1:="bureau 1"
On Error Resume Next
Set PLV = PL.SpecialCells(xlCellTypeVisible)
If Err <> 0 Then
    Err.Clear
    O1.Range("A1").AutoFilter
    MsgBox "Aucune donnée filtrée !"
    Exit Sub
End If
On Error GoTo 0
PLV.Copy
Set O2 = Sheets("feuil3")
Set DEST = O2.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)
DEST.PasteSpecial Paste:=xlValues, Transpose:=False
End Sub

le code renvoie la selection sur la feuille 3 mais c'est bien les destination en feuille 2 que j'aimerais contrôler ....
Sinon je ne sais pas comment faire pour répéter la même opération sans alourdir le code pour mes 29 postes et je n'arrive pas a filtrer les cellules copiées de la plus petite à la plus grande ( n° ) dans la feuille de destination ...

Quelqu'un aurait une idée ?

 

[job75]

Re : Problèmes d'export de données

Bonsoir,

Fichier joint avec cette macro :

Sub Transfert()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim P As Range, i&, c As Range, derlig&, c1 As Range
Set P = Feuil1.[A2].CurrentRegion
P.Sort P(, 7), xlAscending, , P(, 3), xlAscending, Header:=xlYes 'tri
For i = 2 To P.Rows.Count
  Set c = Feuil2.Cells.Find(P(i, 7) & "*", [IV65536], xlValues, xlWhole)
  If Not c Is Nothing Then
    derlig = c.Row + 1 + Val(Mid(c, InStr(c, "(") + 1))
    Set c1 = c(1, 2).EntireColumn.Find("", c(2, 2))
    If c1.Row <= derlig Then
      c1 = P(i, 3)
      c1(1, 2) = P(i, 1)
      c1(1, 3) = P(i, 2)
    End If
  End If
Next
Feuil2.Activate
End Sub

Bonne nuit.

 

[christophedb]

Re : Problèmes d'export de données

Merci pour ta réponse Job75
super sympa le seul hic c'est que je ne comprends pas du tout le code,
est il possible pour toi de le commenter,

Je dois transposer ce code sur une base de données si dans l'exemple il n'y a que 7 colonnes
dans la fichier initial il y a 29 postes et 20 colonnes .
je n'ai que quelques notions en vba et j'aimerais comprendre ce que je fais.
merci d'avance si tu peux m'expliquer ce code qui est vraiment ce que je recherche.

Je vais inscrire ce que je crois comprendre, peux tu me corriger ?

Set P = Feuil1.[A2].CurrentRegion

selectionne les cellules autour de A2 dans la feuille 1 mais lesquelles par définition ? celles qui sont non vides
dans tout le tableau ?

P.Sort P(, 7), xlAscending, , P(, 3), xlAscending, Header:=xlYes 'tri

tri sur la colonne 7 par ordre alphabétique ( croissant ) et la colonne 3 ( cellule ) croissant et indique qu'il y a un entête..

For i = 2 To P.Rows.Count

on boucle de 2 a la dernière ligne non vide

 Set c = Feuil2.Cells.Find(P(i, 7) & "*", [IV65536], xlValues, xlWhole)
  If Not c Is Nothing Then
    derlig = c.Row + 1 + Val(Mid(c, InStr(c, "(") + 1))
    Set c1 = c(1, 2).EntireColumn.Find("", c(2, 2))
    If c1.Row <= derlig Then
      c1 = P(i, 3)
      c1(1, 2) = P(i, 1)
      c1(1, 3) = P(i, 2)
    End If
  End If
Next

C'est ici que je suis perdu, je n'arrive pas à comprendre comment les données sont collées dans la feuille 2 aux bons emplacements ....
De plus c'est important que je puisse adapter car dans mon fichier comme je le dis, les cellules ne son pas contiguë

merci de m'éclairer un peu plus ...

 

[job75]

Re : Problèmes d'export de données

Bonjour christophdb, le forum,

Quelques compléments et commentaires :

Sub Transfert()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim P As Range, t, i&, c As Range, h&, c1 As Range
Set P = Feuil1.[A2].CurrentRegion
t = P 'mémorisation
Application.ScreenUpdating = False 'fige l'écran
P.Sort P(, 7), xlAscending, , P(, 3), xlAscending, Header:=xlYes 'tri
For i = 2 To P.Rows.Count
  '---recherche du début du tableau---
  Set c = Feuil2.Cells.Find(P(i, 7) & "*", [IV65536], xlValues, xlWhole)
  If Not c Is Nothing Then
    '---nombre de lignes à remplir---
    h = Val(Mid(c, InStr(c, "(") + 1))
    '---RAZ du tableau avant remplissage---
    If i = Application.Match(P(i, 7), P.Columns(7), 0) Then _
      c(3, 2).Resize(h, 3) = ""
    '---1ère cellule vide---
    Set c1 = c(1, 2).EntireColumn.Find("", c(2, 2))
    If c1.Row <= c.Row + 1 + h Then
      c1 = P(i, 3)
      c1(1, 2) = P(i, 1)
      c1(1, 3) = P(i, 2)
    End If
  End If
Next
P = t 'facultatif, retour à l'ordre initial en Feuil1
Feuil2.Activate 'facultatif
End Sub

- en Feuil1 le tableau est mémorisé pour être restitué dans l'ordre initial à la fin

- en Feuil2 chaque tableau est effacé (RAZ) avant remplissage

- la macro se déclenche quand on active Feuil2

- formule en Feuil2!F17, à tirer vers le bas :

=--STXT(E17;TROUVE("(";E17)+1;TROUVE(")";E17)-TROUVE("(";E17)-1)

- formule en Feuil2!G17 :

=MIN(F17;NB.SI(Feuil1!G:G;GAUCHE(E17;TROUVE("(";E17)-2)))

Bonne journée et A+

 

[christophedb]

Re : Problèmes d'export de données

merci pour ce complément,
c'est un peu plus clair pour moi !
bonne journée

 

[job75]

Re : Problèmes d'export de données

Re,

Dans le fichier (2) j'ai corrigé les 2 formules en Feuil2.

A+

 

[christophedb]

Re : Problèmes d'export de données

vraiment aimable d'avoir su trouver une solution à ce problème,
j'aurais encore d'autres questions , je vais déjà adapter ce code pour ma base de données.
il ne me reste plus maintenant que de créer les différents modules impressions pour mon projet.
je vais créer un autre post a cette fin.

 

[job75]

Re : Problèmes d'export de données

Re,

S'il s'agit d'imprimer les tableaux en Feuil2 un par un, voyez ce fichier (3).

Le code de l'UserForm :

Private Sub ComboBox1_Change()
If ComboBox1.ListIndex = -1 Then Exit Sub
Dim c As Range, h&
'---recherche du début du tableau---
Set c = Feuil2.Cells.Find(ComboBox1 & "*", Feuil2.[IV65536], xlValues, xlWhole)
If Not c Is Nothing Then
  '---nombre de lignes à remplir---
  h = Val(Mid(c, InStr(c, "(") + 1))
  Feuil2.PageSetup.PrintArea = c.Resize(2 + h, 4).Address
  Me.Hide
  Feuil2.PrintPreview '.PrintOut
  Me.Show
End If
End Sub

Private Sub UserForm_Initialize()
'Feuil1 est le CodeName d la feuille
Dim P As Range, t, d As Object, i&, F As Object
Set P = Feuil1.[A2].CurrentRegion
t = P 'mémorisation
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False 'fige l'écran
P.Sort P(, 7), xlAscending, Header:=xlYes 'tri
For i = 2 To P.Rows.Count
  d(P(i, 7).Value) = ""
Next
ComboBox1.List = d.keys
P = t 'retour à l'ordre initial
Set F = ActiveSheet
Transfert
F.Activate
Application.ScreenUpdating = True
End Sub

A+

 

[christophedb]

Re : Problèmes d'export de données

bonjour,

cela me servira certainement,
je vais essayer de l'adapter et le comprendre
sinon les impressions se feront sur des mises en page type ( 1 par page )
je devrai simplement exporter les données sélectionnées vers des cellules précises de la feuille à imprimer
le choix des données à exporter devra se faire parmis les quelques colonnes que ma BD dispose.

je vais regarder cela de plus près et essayer de m'en sortir.
encore merci

 

[job75]

Re : Problèmes d'export de données

Re, pour finir,

Sur la macro Transfert je découvre un phénomène intéressant :

Set c = Feuil2.Cells.Find(P(i, 7) & "*", [IV65536], xlValues, xlWhole)

Normalement j'aurais dû préciser la feuille devant [IV65536] :

Set c = Feuil2.Cells.Find(P(i, 7) & "*", Feuil2.[IV65536], xlValues, xlWhole)

On pouvait donc s'attendre à ce que cette ligne beugue.

Eh bien elle ne beugue pas, du moins sur Excel 2010.

Edit : dans l'UserForm j'avais écrit à la fin t = P au lieu de P = t, je corrige le fichier (3).

A+

 

[job75]

Re : Problèmes d'export de données

Bonjour à tous,

Sur Excel 2010 la liste déroulante restait déroulée... et en plus elle s'affichait sur l'aperçu...

Le mieux est d'utiliser un Label ou un CommandButton dans l'UserForm, voyez ce fichier (4).

A+