vba erreur 80010108

Version imprimable

vba erreur 80010108

Bonjour à tous,

Je ne comprends pas pourquoi la copie se fait à l'infinie et j'obtiens une erreur 800 10 108 ...Pouvez-vous m'aider s'il vous plaît?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Sub bliblil()
 
Dim wb As Workbook
Dim wb2 As Workbook
 
 
   'Contrat
   Set wb = GetObject("blabla.xlsx")
   wb.Activate
   Nb_Lignes = wb.Sheets(1).UsedRange.Rows.Count
   MsgBox Nb_Lignes
 
   'Affectation
   Set wb2 = GetObject("blabla2.xlsx")
   wb2.Activate
   Nb_Lignes2 = wb2.Sheets(1).UsedRange.Rows.Count
 
 
 
   wb.Sheets(1).Range("A2:A" & Nb_Lignes).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
   Dim plage As Range
   Dim plage2 As Range
 
 
   Set plage = wb.Sheets(1).Range("A2:A" & Nb_Lignes).SpecialCells(xlCellTypeVisible)
   wb.Sheets(1).ShowAllData
   Dim pl
 
   For Each cell In plage
 
        For i = 2 To Nb_Lignes2
 
            If wb2.Sheets(1).Range("A" & i).Value = cell.Value _
            And wb2.Sheets(1).Range("D" & i).Value = wb.Sheets(1).Range("D" & cell.Row).Value _
            And wb2.Sheets(1).Range("E" & i).Value = wb.Sheets(1).Range("E" & cell.Row).Value Then
 
                wb.Sheets(1).Range("M" & cell.Row).Value = wb2.Sheets(1).Range("D" & i).Value
                wb.Sheets(1).Range("N" & cell.Row).Value = wb2.Sheets(1).Range("E" & i).Value
                wb.Sheets(1).Range("O" & cell.Row).Value = wb2.Sheets(1).Range("F" & i).Value
                wb.Sheets(1).Range("P" & cell.Row).Value = wb2.Sheets(1).Range("G" & i).Value
 
            ElseIf wb2.Sheets(1).Range("A" & i).Value = cell.Value _
            And (wb2.Sheets(1).Range("D" & i).Value <> wb.Sheets(1).Range("D" & cell.Row).Value _
            Or wb2.Sheets(1).Range("E" & i).Value <> wb.Sheets(1).Range("E" & cell.Row).Value) Then
 
              wb.Sheets(1).Activate
              wb.Sheets(1).Range("A" & cell.Row + 1).Select
              Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
 
              wb.Sheets(1).Range("A" & cell.Row).Copy
              wb.Sheets(1).Paste Destination:=wb.Sheets(1).Range("A" & cell.Row + 1)
 
              i = i + 1
 
            End If
 
        Next i
 
   Next cell
 
 
End Sub

15/05/2015, 10h55
Daniel.C

Bonjour,

Est-ce que tu peux mettre les deux classeurs - sans données confidentielles - en pièce jointe ?

Bonjour,

pour commencer, c'est dangereux de modifier ton indice i dans ta boucle For ... normalement on laisse la boucle gérer l'incrémentation pour ne pas générer de comportements inattendus
je ne comprend pas très bien ce que dois faire ta macro .. ce qui m'empêche de certifier l'origine de ton problème et surtout de proposer :

- d'inverser tes deux boucles For

Code:

1
2
For Each Cell In Plage
    For i = 2 To Nb_Lignes2

OU

- de gérer différemment tes deux conditions au sein de ton IF/ELSIF

ça pourrait même être les deux à la fois ....
j'ai été obligé de retoucher ton code pour commencer à comprendre la mécanique, mais la finalité m'échappe.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub bliblil()
Dim ShSource As Worksheet
Dim ShDest As Worksheet
Dim PlageSource As Range
Dim Cell As Range
 
    Set ShSource = Workbooks("blabla.xls").Sheets(1)
    Nb_Lignes = ShSource.UsedRange.Rows.Count
 
    Set ShDest = Workbooks("blabla2.xls").Sheets(1)
    Nb_Lignes2 = ShDest.UsedRange.Rows.Count
 
    With ShSource
 
        .Range("A2:A" & Nb_Lignes).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set PlageSource = .Range("A2:A" & Nb_Lignes).SpecialCells(xlCellTypeVisible)
        .ShowAllData
 
        For Each Cell In PlageSource
             For i = 2 To Nb_Lignes2
                 If ShDest.Range("A" & i).Value = Cell.Value _
                 And ShDest.Range("D" & i).Value = .Range("D" & Cell.Row).Value _
                 And ShDest.Range("E" & i).Value = .Range("E" & Cell.Row).Value Then
 
                     .Range("M" & Cell.Row).Value = ShDest.Range("D" & i).Value
                     .Range("N" & Cell.Row).Value = ShDest.Range("E" & i).Value
                     .Range("O" & Cell.Row).Value = ShDest.Range("F" & i).Value
                     .Range("P" & Cell.Row).Value = ShDest.Range("G" & i).Value
 
                 ElseIf ShDest.Range("A" & i).Value = Cell.Value _
                 And (ShDest.Range("D" & i).Value <> .Range("D" & Cell.Row).Value _
                 Or ShDest.Range("E" & i).Value <> .Range("E" & Cell.Row).Value) Then
 
                   .Range("A" & Cell.Row + 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
                   .Range("A" & Cell.Row).Copy .Range("A" & Cell.Row + 1)
 
                   i = i + 1
                 End If
             Next i
        Next Cell
    End With
End Sub

15/05/2015, 11h39
sarafati

2 pièce(s) jointe(s)

Merci à vous deux,

J'ai mis deux fichiers simples en pièce jointe.

En fait mes traitements se basent tout d'abord par rapport à la première colonne si nous avons la même lettre dans la première colonnes et dans les deux fichiers alors je compare les dates, si les dates sont différentes alors on ajoute une ligne dans le fichiers blabla et on copie la ligne de blibli qui comporte les dates différentes.

Mon code bug est au niveau du copier coller...

Merci,
15/05/2015, 12h32
joe.levrai

Je commence à comprendre une partie de ce que tu veux

je note également que si les données sont identiques, tu copies des cellules de blibli que tu colles dans blabla

on va reprendre pas à pas, je pense qu'il y a du superflu dans ton code :

- on regarde les valeurs en colonne A
- si c'est identique, on regarde les couples de dates dans les deux fichiers
- si les couples sont identiques, on copie des cellules de blibli vers blabla (sur la même ligne)
- si les couple sont différents, tu prends la ligne complète de blabla et tu l'insère en bas de la page du fichier blabla

c'est ça ?
ça signifie donc qu'on doit :

- parcourir chaque ligne de blibli
- la comparer avec chaque ligne de la plage d'origine de blabla (je parle bien de plage d'origine, car quand on va éventuellement ajouter des lignes, la plage va augmenter et on ne doit pas inclure les nouvelles lignes)
- quand on a vu si la ligne de blibli existait ou non (et qu'on l'a insérée en bas de feuille, ou copié les cellules voulues dans la ligne de blabla) ... on passe à la ligne blibli suivante
- une fois qu'on a fait chaque ligne de blibli, la macro s'arrête

maintenant, tu peux nous confirmer que dans ta plage d'origine de blabla, tu n'auras jamais deux fois la même valeur en colonne A ? Sinon ça pose problème, et il faut encore nous préciser comment ton code doit réagir
15/05/2015, 13h02
sarafati

- on regarde les valeurs en colonne A
- si c'est identique, on regarde les couples de dates dans les deux fichiers
- si les couples sont identiques, on copie des cellules de blibli vers blabla (sur la même ligne)
- si les couple sont différents, tu prends la ligne complète de blabla et tu l'insère en bas de la page du fichier blabla

Vous avez très bien compris le mécanisme, et en effet dans blabla il se peut qu'il y ait deux fois la même valeur en colonne A, dans ce cas la on compare avec toutes les dates de la même valeur

Merci,
15/05/2015, 13h10
sarafati

Si les couples sont différents on insère la ligne blibli sous la ligne ou la colonne A est identique

j'ai légèrement changé mon code afin de prendre en compte les doublons de la colonne A.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub tableauFinal()
 
Dim wb As Workbook
Dim wb2 As Workbook
 
 
   Set wb = GetObject("blabla.xlsx")
   wb.Activate
   Nb_Lignes = wb.Sheets(1).UsedRange.Rows.Count
   MsgBox Nb_Lignes
 
 
   Set wb2 = GetObject("blabla2.xlsx")
   wb2.Activate
   Nb_Lignes2 = wb2.Sheets(1).UsedRange.Rows.Count
 
 
 
 
   For j = 2 To Nb_Lignes
 
        For i = 2 To Nb_Lignes2
 
            If wb2.Sheets(1).Range("A" & i).Value = wb.Sheets(1).Range("A" & j).Value _
            And wb2.Sheets(1).Range("D" & i).Value = wb.Sheets(1).Range("D" & j).Value _
            And wb2.Sheets(1).Range("E" & i).Value = wb.Sheets(1).Range("E" & j).Value Then
 
                wb.Sheets(1).Range("M" & j).Value = wb2.Sheets(1).Range("D" & i).Value
                wb.Sheets(1).Range("N" & j).Value = wb2.Sheets(1).Range("E" & i).Value
                wb.Sheets(1).Range("O" & j).Value = wb2.Sheets(1).Range("F" & i).Value
                wb.Sheets(1).Range("P" & j).Value = wb2.Sheets(1).Range("G" & i).Value
 
            ElseIf wb2.Sheets(1).Range("A" & i).Value = wb.Sheets(1).Range("A" & j).Value _
            And (wb2.Sheets(1).Range("D" & i).Value <> wb.Sheets(1).Range("D" & j).Value _
            Or wb2.Sheets(1).Range("E" & i).Value <> wb.Sheets(1).Range("E" & j).Value) Then
 
                If wb.Sheets(1).Range("A" & j).Value <> wb.Sheets(1).Range("A" & j + 1).Value Then
 
                    wb.Sheets(1).Activate
                    wb.Sheets(1).Range("A" & j + 1).Select
                    Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
 
                    wb.Sheets(1).Range("A" & j).Copy
                    wb.Sheets(1).Paste Destination:=wb.Sheets(1).Range("A" & j + 1)
 
                    i = i + 1
                End If
 
            End If
 
 
        Next i
 
 
   Next j
 
 
End Sub

J'ai essayé la première version que vous m'avez proposé mais elle ne fonctionne pas chez moi ...

15/05/2015, 14h17
joe.levrai

Le problème c'est que tu veux insérer des lignes dans ta plage qui est parcourue par une boucle FOR

il va falloir utiliser une troisième feuille pour reconstituer le résultat attendu dans le classeur blabla
et ensuite supprimer la feuille initiale de blabla + renommer la troisième feuille avec le nom de la feuille supprimée

je regarde plus en détail dès que possible (pas avant ce soir je pense ... désolé), la solution est moins évidente qu'elle n'y paraît ;)

peut être qu'un autre contributeur interviendra avant
15/05/2015, 14h24
sarafati

ok très bien je vai tenter cette méthode, MERCI BEAUCOUP.
16/05/2015, 01h18
joe.levrai

Suivant le contenu de ta base de donnée, il est possible de ne pas passer par une feuille de transition

tu copies les lignes à créer les unes en dessous des autres à la fin de ta plage

ensuite tu peux effectuer un tri de tes données pour rassembler les valeurs identiques ? (méthode Sort de l'objet Range)
17/05/2015, 21h33
sarafati

Je me suis servie d'une autre feuille je n'ai plus de bug.

Merci pour cette idée!