Résolu Copier/Coller à partir d'un autre classeur sous condition + opération sur données

M

Matiouz59

Nouveau membre
Bonjour à tous, je viens ici afin de réclamer votre aide.
J'ai eu beau chercher, fouiner, farfouiller un peu partout sur internet je n'ai pas trouvé de solution.

Je vous explique ce que je cherche à faire:
J'ai 2 classeurs (HS et TabAgents), il n'y a qu'1 feuille dans le classeur HS mais pluseurs dans TabAgents (Agents,HS, RC,CA) ce que je cherche à faire c'est récupérer 2 colonnes du classeur HS (E et I) suivant une condition (à savoir colonne A = 590382) et les coller dans la feuille HS du classeur TabAgents.
Mon second soucis étant pour un calcul à faire, à savoir en fonction des 2 colonne copiées (nouvellement nommées A et B après collage) comparer la colonne A de la feuille HS avec la colonne A de a feuille Agents puis si la correspondanc est trouvée, regarder si dans la colonne D de Agents il y a un certain service (DISTRI,ENCADREMENT,RCES) et additionner les valeurs de la colonne B de HS correspondant aux critères pour au final afficher le résultat dans un label d'un UserForm.

J'ai testé différents code et voici celui qui m'a permis d'aller le plus loins (sachant que le copier/coller est vraiment fait à l'arrache ne sachant pas comment rajouter une condition):

Code: 
Private Sub CommandButton1_Click()
    'Copie des colonnes E et I du classeur HS vers la feuille HS du classeur TabAgents
    Windows("HS.xlsx").Activate
    Range("E3510:E5481").Select
    Selection.Copy
    Windows("TabAgents.xls").Activate
    Range("A1").Select
    ActiveSheet.Paste
    Windows("HS.xlsx").Activate
    Range("I3510:I5481").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("TabAgents.xls").Activate
    Range("B1").Select
    ActiveSheet.Paste
    
Dim Ls As String, Lg As String
Lg = Sheets("Agents").Cells(65536, 1).End(xlUp).Row + 1 'Je définie la taille de ma feuille Agents
Ls = Sheets("HS").Cells(65536, 1).End(xlUp).Row + 1 'Je définie la taille de ma feuille HS
Dim i As Integer, j As Integer
Dim k As Double
i = 1
j = 2
k = 0

'Parcours des 2 feuilles + opératon  
For i = 1 To Ls
    For j = 2 To Lg
        If (Sheets("HS").Cells(i, "A").Value Like Sheets("Agents").Cells(j, "A").Value) And (Sheets("Agents").Cells(j, "D") Like ENCADREMENT) Then
            k = k + Sheets("HS").Cells(i, "B").Value
        End If
    Next
Next
 
'Affichage sur le label   
UserForm6.lbHs.Caption = k
    
End Sub
Ce code fait tout simplement planter excel.(je sais que le copier/coller est très très moche mais je n'avais pas d'autres solution :x)

J'ai également testé d'autres façons d'extraire ce qui m'intéressait (test effectué sans la condition):

Code: 
Set W1 = Workbooks("C:\Users\mxg380\Desktop\Agent\HS.xlsx")
Set s1 = W1.Sheets("Feuil1")
Set W2 = ThisWorkbook
Set s2 = W2.Sheets(HS)
s1.Range("E6:E5000").Copy Destination:=s2.Range("A1")
s1.Range("I6.I5000").Copy Destination:=s2.Range("B1")

Sachant que pour ce code j'ai une erreur à cette ligne:
Code: 
Set W1 = Workbooks("C:\Users\mxg380\Desktop\Agent\HS.xlsx")

Merci d'avance pour l'aide que vous pourrez m'apporter :)
 
M

Matiouz59

Nouveau membre
N'étant pas resté inactif, j'ai trouvé la première partie de la solution (copier/coller avec condition) mais j'ai une erreur lorsque j'essaye d'effectuer le traitement que je souhaite faire:

Code: 
Dim NomFichier As String, lg As String, ls As String
Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer
NomFichier = Dir("C:\Users\mxg380\Desktop\Agent\hs.xls") 'NomFichier est le fichier que tu veux lire
i = 1
j = 6
m = 0
Workbooks.Open NomFichier
While (Workbooks(NomFichier).Sheets(1).Range("A" & j).Value <> "")
    If (Workbooks(NomFichier).Sheets(1).Range("A" & j).Value Like 590382) Then
        ThisWorkbook.Sheets("HS").Range("A" & i).Value = Workbooks(NomFichier).Sheets(1).Range("E" & j).Value
        ThisWorkbook.Sheets("HS").Range("B" & i).Value = Workbooks(NomFichier).Sheets(1).Range("I" & j).Value
        i = i + 1
    End If
    j = j + 1
Wend

With ThisWorkbook
    lg = Sheets("Agents").Cells(65536, 1).End(xlUp).Row + 1
    ls = Sheets("HS").Cells(65536, 1).End(xlUp).Rox + 1

    For k = 2 To lg
        If Sheets("Agents").Cells(k, "D").Value Like CONCENTRATION Then
            For l = 1 To ls
                If Sheets("HS").Cells(l, "A").Value Like Sheets("Agents").Cells(k, "A").Value Then
                    m = m + Sheets("HS").Cells(l, "B").Value
                End If
            Next
        End If
    Next
    UserForm4.lbHs.Caption = m
End With

Ce code me renvoie une erreur sur cette ligne
Code: 
 lg = Sheets("Agents").Cells(65536, 1).End(xlUp).Row + 1
"Erreur d'execution 9 l'indice n'impartient pas à la selection"
 
M

Matiouz59

Nouveau membre
Meilleure réponse
Solution trouvée :)

Code: 
Dim NomFichier As String, ls As String, lg As String
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Double
lg = Sheets("Agents").Cells(65536, 1).End(xlUp).Row + 1
NomFichier = Dir("C:\Users\mxg380\Desktop\Agent\hss.xls") 'Nom du fichier à ouvrir
i = 1
j = 6
m = 0

'Copier/coller des données
Workbooks.Open NomFichier
While (Workbooks(NomFichier).Sheets(1).Range("A" & j).Value <> "")
    If (Workbooks(NomFichier).Sheets(1).Range("A" & j).Value Like 590382) Then
        ThisWorkbook.Sheets("HS").Range("A" & i).Value = Workbooks(NomFichier).Sheets(1).Range("E" & j).Value
        ThisWorkbook.Sheets("HS").Range("B" & i).Value = Workbooks(NomFichier).Sheets(1).Range("I" & j).Value
        i = i + 1
    End If
    j = j + 1
Wend
ActiveWorkbook.Close False 'Fermeture du classeur

'traitement des données
ls = Sheets("HS").Cells(65536, 1).End(xlUp).Row + 1
For k = 2 To lg
    If Sheets("Agents").Cells(k, "D").Value Like "CONCENTRATION" Then
        For l = 1 To ls
            If Sheets("HS").Cells(l, "A").Value Like Sheets("Agents").Cells(k, "A").Value Then
                m = m + Sheets("HS").Cells(l, "B").Value
            End If
        Next
    End If
Next
UserForm4.lbHs.Caption = m

Merci quand même d'avoir regardé :)
 
M

Matiouz59

Nouveau membre
Bonjour à tous, je reviens vers vous avec un autre problème mais sur les même fichier :bounce:

Je m'explique, suite à certaines discussions j'ai du revoir ma façon de faire pour extraire les données du classeur source, je vais essayer de faire au plus simple pour m'expliquer:
J'ai toujours ma feuille "Agents" avec donc la liste d'agents et surtout des identifiants pour ces agents (en colonne A) dans les fichiers sources dont je souhaite extraire les données j'ai également pour chaque agent un identifiant (en colonne E), pour finir j'ai toujours ma 3eme feuille dans laquelle je souhaite coller les données extraites.
Ce que je souhaite faire:
-Parcourrir mes 2 feuilles et comparer les identifiants
-Si une correspondance est trouvée, copier certaines cellules de la ligne dans la 3 eme feuille

Ce qui m'énerve le plus c'est que ça à l'air très simple dis comme ça mais impossible de trouver la solution malgrés plusieurs essais différent, je demande donc votre aide :ange:

Voici les essais que j'ai pu faire jusqu'ici:
Code: 
Dim NomFichier As String, lg As String
Dim i As Integer, j As Integer, k As Integer
lg = Sheets("Agents").Cells(65536, 1).End(xlUp).Row + 1
NomFichier = Dir("U:\PUBLIC\11. Gestion\log_extract_excel\caa.xls") 'Définition du premier fichier source à parcourir
i = 1
j = 4
k = 1

'Copier/coller des données CA
Workbooks.Open NomFichier

While (k < lg + 1 And Workbooks(NomFichier).Sheets(1).Range("A" & j).Value <> "")
        If (Workbooks(NomFichier).Sheets(1).Range("E" & j).Value Like ThisWorkbook.Sheets("Agents").Range("A" & k).Value) Then
            ThisWorkbook.Sheets("CA").Range("A" & i).Value = Workbooks(NomFichier).Sheets(1).Range("E" & j).Value
            ThisWorkbook.Sheets("CA").Range("B" & i).Value = Workbooks(NomFichier).Sheets(1).Range("H" & j).Value
            ThisWorkbook.Sheets("CA").Range("C" & i).Value = Workbooks(NomFichier).Sheets(1).Range("I" & j).Value
            ThisWorkbook.Sheets("CA").Range("D" & i).Value = Workbooks(NomFichier).Sheets(1).Range("J" & j).Value
            ThisWorkbook.Sheets("CA").Range("E" & i).Value = Workbooks(NomFichier).Sheets(1).Range("K" & j).Value
            ThisWorkbook.Sheets("CA").Range("F" & i).Value = Workbooks(NomFichier).Sheets(1).Range("L" & j).Value
            ThisWorkbook.Sheets("CA").Range("G" & i).Value = Workbooks(NomFichier).Sheets(1).Range("H" & j).Value + Workbooks(NomFichier).Sheets(1).Range("I" & j).Value + Workbooks(NomFichier).Sheets(1).Range("J" & j).Value + Workbooks(NomFichier).Sheets(1).Range("K" & j).Value + Workbooks(NomFichier).Sheets(1).Range("L" & j).Value
            i = i + 1
        End If
        j = j + 1
        k = k + 1
Wend

Ce code ne me copie rien du tout
Autre essai:
Code: 
Dim NomFichier As String, lg As String
Dim i As Integer, j As Integer, k As Integer
lg = Sheets("Agents").Cells(65536, 1).End(xlUp).Row + 1
NomFichier = Dir("U:\PUBLIC\11. Gestion\log_extract_excel\caa.xls") 'Définition du premier fichier source à parcourir
i = 1
j = 4
k = 1

'Copier/coller des données CA
Workbooks.Open NomFichier

For k = 2 To lg + 1 'Du début à la fin de Agent
    While (Workbooks(NomFichier).Sheets(1).Range("A" & j).Value <> "") 'TQ fichier source pas finit
        If (Workbooks(NomFichier).Sheets(1).Range("E" & j).Value Like ThisWorkbook.Sheets("Agents").Range("A" & k).Value) Then 'recherche des correspondances d'id
            ThisWorkbook.Sheets("CA").Range("A" & i).Value = Workbooks(NomFichier).Sheets(1).Range("E" & j).Value
            ThisWorkbook.Sheets("CA").Range("B" & i).Value = Workbooks(NomFichier).Sheets(1).Range("H" & j).Value
            ThisWorkbook.Sheets("CA").Range("C" & i).Value = Workbooks(NomFichier).Sheets(1).Range("I" & j).Value
            ThisWorkbook.Sheets("CA").Range("D" & i).Value = Workbooks(NomFichier).Sheets(1).Range("J" & j).Value
            ThisWorkbook.Sheets("CA").Range("E" & i).Value = Workbooks(NomFichier).Sheets(1).Range("K" & j).Value
            ThisWorkbook.Sheets("CA").Range("F" & i).Value = Workbooks(NomFichier).Sheets(1).Range("L" & j).Value
            ThisWorkbook.Sheets("CA").Range("G" & i).Value = Workbooks(NomFichier).Sheets(1).Range("H" & j).Value + Workbooks(NomFichier).Sheets(1).Range("I" & j).Value + Workbooks(NomFichier).Sheets(1).Range("J" & j).Value + Workbooks(NomFichier).Sheets(1).Range("K" & j).Value + Workbooks(NomFichier).Sheets(1).Range("L" & j).Value
            i = i + 1
        End If
        j = j + 1
    Wend
Next

Celui ci ne me copie/colle qu'une seule ligne...
Je suis un peu perdu j'espère que vous pourrez m'aider :)
 
zeb

zeb

Modérateur
Bon, pour commencer, il y a quelques petites erreurs.

Excel peut avoir beaucoup de lignes. Or un "Integer" n'est pas assez grand. On peut alors utiliser un "Long", voire ne pas se servir de coordonnées du tout.
"While .. Wend" c'est obsolète. Utilise "Do While .. Loop".
En fait, n'utilise pas de Loop puisque les zones sont connues !

Il n'y a pas besoin de parenthèse autour des conditions.

Quand on jongle avec plusieurs classeurs et plusieurs onglets, il est préférable de prendre le temps de déclarer une variable pour chacun.
Ici, une variable par feuille devrait suffire.

Code: 
Dim ws_ca  as Worksheet
Dim ws_agt as Worksheet
Dim ws_src as Worksheet
Set ws_ca  = ThisWorkbook.Worksheets("CA")
Set ws_agt = ThisWorkbook.Worksheets("Agents")
Set ws_src = Workbooks.Open(NomFichier).Worksheets(1)

' Les zones de parcours dans AGENT et dans SOURCE
Dim rows_agt As Range, row_agt As Range
Dim rows_src As Range, row_src As Range
Dim                    row_ca  As Range
Set rows_agt = ws_agt.Range(ws_agt.Rows(2), ws_agt.Cells(Application.Rows.Count, 1).End(xlUp).EntireRow).Rows
Set rows_src = ws_src.Range(ws_src.Rows(4), ws_src.Cells(Application.Rows.Count, 1).End(xlUp).EntireRow).Rows

Set row_ca = ws_ca.Rows(1)
For Each row_ca In rows_ca
	For Each row_src In rows_src
		If row_src.Cells(5).Value Like row_ca.Cells(1).Value Then
			row_ca.Cells(1).Value = row_src.Cells( 5).Value
			row_ca.Cells(2).Value = row_src.Cells( 8).Value
			row_ca.Cells(3).Value = row_src.Cells( 9).Value
			row_ca.Cells(4).Value = row_src.Cells(10).Value
			row_ca.Cells(5).Value = row_src.Cells(11).Value
			row_ca.Cells(6).Value = row_src.Cells(12).Value
			row_ca.Cells(7).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
			Set row_ca = row_ca.Offset(1)
		End If
	Next
Next

Un truc me gêne. Pourquoi utiliser Like ?
 
M

Matiouz59

Nouveau membre
J'utilise Like simplement car j'ai repris le code que j'avais avant ou je faisais mon extraction à partir d'un critère précis donc une chaine de caractère c'est la seule raison pour laquelle j'utilisais Like je ne l'ai pas changé sur mon nouveau code ^^
Merci pour ta réponse je vais me pencher dessus :)
 
zeb

zeb

Modérateur
Attention, ma réponse reprend 100% de ton code.
Donc si il y a une incohérence par rapport à tes données, elles persisteront.
Mais j'estime que ce code est plus clair, plus facile à relire et donc plus facile à déboguer.
 
M

Matiouz59

Nouveau membre
Bon j'ai rgardé ton code et il y a certaines choses qui me turlupine :sarcastic:
Code: 
For Each row_ca In rows_ca
Ici tu utilise rows_ca mais tu ne l'as pas défini avant, la solution est elle à cette ligne?
Code: 
Dim rows_ca As Range,row_ca  As Range

Ensuite autre chose que je ne comprend pas sur cette ligne:
Code: 
If row_src.Cells(5).Value Like row_ca.Cells(1).Value Then
Dans cette ligne tu compare la cellule 5 de la source (les ID) avec la cellule 1 des CA (qui est vide au départ) ça ne serait pas plutôt ça?
Code: 
If row_src.Cells(5).Value Like row_agt.Cells(1).Value Then
(row_agt que tu définis plus haut mais que tu n'utilise pas)
Les comparaisons que je cherche à faire sont entre la source et agent, CA ne sert qu'a coller les résultats.

Ensuite par acquis de conscience j'ai tout de même essayer ton code et il me renvoie une erreur à cette ligne:
Code: 
For Each row_ca In rows_ca
L'erreur est "erreur d'execution 424: Objet requis" est ce que cette erreur vient du premier doute que je me suis fait? :??:

Et pour finir merci de prendre le temps de m'aider :)
 
M

Matiouz59

Nouveau membre
J'ai modifier une petite partie de ton code à savoir
Code: 
For Each row_ca In rows_ca
et
Code: 
If row_src.Cells(5).Value Like row_ca.Cells(1).Value Then

par
Code: 
For Each row_agt In rows_agt
et
Code: 
If row_src.Cells(5).Value Like row_agt.Cells(1).Value Then

Avec cette modification il semblerait que ça fonctionne je vais tenter de vérifier ça et je reviens par ici pour te tenir au jus :)


 
zeb

zeb

Modérateur
Que faire ?
1°) Me dire que j'ai fait n'importe quoi. Ça c'est fait.
2°) Relire ceci :
Code: 
For Each row_agt In rows_agt
	For Each row_src In rows_src
		If row_src.Cells(5).Value Like row_agt.Cells(1).Value Then
			row_ca.Cells(1).Value = row_src.Cells( 5).Value
			row_ca.Cells(2).Value = row_src.Cells( 8).Value
			row_ca.Cells(3).Value = row_src.Cells( 9).Value
			row_ca.Cells(4).Value = row_src.Cells(10).Value
			row_ca.Cells(5).Value = row_src.Cells(11).Value
			row_ca.Cells(6).Value = row_src.Cells(12).Value
			row_ca.Cells(7).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
			Set row_ca = row_ca.Offset(1)
		End If
	Next
Next

3°) Comprendre ce que je propose pour corriger soi-même. :sarcastic:

L'algo est simple et classique : deux boucles imbriquées et un curseur.
Les boucles se sont bien sûr les For Each sur les lignes, le curseur, c'est row_ca qu'on déplace avec Offset.
 
M

Matiouz59

Nouveau membre
Loins de moi l'idée de dire que tu as fait n'importe quoi, même si je ne poste pas souvent, je viens sur ce forum régulièrement pour tenter de trouver des réponses à mes problèmes (des fois avec succés des fois non :D) et je sais très bien que chacun de tes codes est réfléchi et pas un regroupement de ligne balancé à la hate pour faire plaisir :p

D'ailleurs sans ton aide je serai probablement en train de m'arracher les cheveux jusqu'à ne plus en avoir (les pauvres :( )

Donc revenons à nos moutons :) La modification que j'ai apportée et que tu as précisée ensuite, fonctionne donc je te remercie réellement, tu as probablement sauvé 80% de mes cheveux et m'a fait gagné énormément de temps, merci à toi :love:

Il ne me reste plus qu'à l'adapter pour les autres extractions que je dois faire
 
zeb

zeb

Modérateur
Alors d'abord, je n'écris pas que des conneries... J'en dit et j'en fait pas mal aussi. :o ... :lol:

Il ne me reste plus qu'à l'adapter pour les autres extractions que je dois faire
Cliquez pour agrandir...
Ah que voilà un bel état d'esprit ! :merci:
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Dernières actus
Derniers messages publiés
Statistiques globales
Discussions
730 152
Messages
6 718 439
Membres
1 586 427
Dernier membre
Huxley88
Partager cette page
Haut