Copie de cellules qui posent problème

Version imprimable

Bonjour, j'ai un peu le même problème mais aucune des solutions proposées ne fonctionnent !
Voici mon code :
Code:

1 2 3 4 5 6 7 8 9 10 Sub surface() '(Cette partie là fonctionne ; elle prend bien la valeur de la cellule K1 et la colle dans la première cellule vide de la colonne Q 'Numéro de profil Range("K1").Select Selection.Copy Range("Q458").Select Selection.End(xlUp).Select Ligne = ActiveCell.Row Range("Q" & Ligne + 1).Select Selection.PasteSpecial Paste:=xlPasteValues
Les deux partie suivante ne fonctionne pas : le paragraphe surface Remblais me colle la valeur de la cellule K1 dans la première cellule vide de la colonne I quand au paragraphe surface remblais il ne renvoi rien
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 'Surface déblais DerniereCelluleRemplie = Columns("I:I").Find("*", , xlValues, , , xlPrevious) Range("I" & DerniereCelluleRemplie).Select Range("R458").Select Selection.End(xlUp).Select Ligne = ActiveCell.Row Range("R" & Ligne + 1).Select Selection.PasteSpecial Paste:=xlPasteValues 'Surface Remblais DerniereCelluleRemplie = Columns("P:P").Find("*", , xlValues, , , xlPrevious) Range("P" & DerniereCelluleRemplie).Select Selection.Copy Range("S458").Select Selection.End(xlUp).Select Ligne = ActiveCell.Row Range("S" & Ligne + 1).Select Selection.PasteSpecial Paste:=xlPasteValues 'Remise à zéro Range("B5:d50,J5:K50").Select Selection.ClearContents Range("B5").Select End Sub
J'ai bien sur essayé avec XlUp et XlDown sans plus de résultat ! Xlup s'entête à me renvoyer le titre de mes collonnes sans tenir compte des valeurs numérique qu'il y a en dessous, et XlDown passe son chemin jusqu'au fin fond de la feuille !
Le pire c'est que dans le code affiché ci-dessus, si je l'exécute pas à pas, les valeurs renvoyé dans le code sont bien les bonnes et pourtant ça ne fonctionne pas !!
Si quelqu'un à une solution se serait sympat car je n'y comprend plus rien
merci pour votre aide

En Fait je viens de trouver une solution peu être pas très élégante mais qui fonctionne : juste en dessous du titre de la colonne je masque une cellule (I4) avec la formule "=recherche(9^9;I5:I50)"qui me renvoi bien cette fois-ci la dernière valeur de la colonne et j'ai modifier ma macro comme suit :
Code:

1 2 3 4 5 6 7 8 'Surface déblais Range("I4").Select Selection.Copy Range("R458").Select Selection.End(xlUp).Select Ligne = ActiveCell.Row Range("R" & Ligne + 1).Select Selection.PasteSpecial Paste:=xlPasteValues
Si cela peu servir à quelqu'un mais je reste quand même sur ma faim et je voudrais bien savoir pourquoi mon code ne fonctionnait pas...

Bonjour,

Citation:

Envoyé par dmoluc

J'ai bien sur essayé avec XlUp et XlDown sans plus de résultat !

Probablement parce que mal utilisé...

Ton code ci-dessous
Code:

1 2 3 4 5 6 7 8 'Surface déblais Range("I4").Select Selection.Copy Range("R458").Select Selection.End(xlUp).Select Ligne = ActiveCell.Row Range("R" & Ligne + 1).Select Selection.PasteSpecial Paste:=xlPasteValues
Peut se résumer à :
Code:

1 2 'Surface déblais Range("R" & Rows.Count).End(xlUp).Offset(1, 0) = Range("I4")

1 pièce(s) jointe(s)

Merci pour l'info :ccool: En fait je découvre juste VBA et encore par obligation car je n'arrive plus à trouver les fonctions nécessaires dans les formules classique.
Je vais donc essayé de simplifier mon code car plus c'est simple mieux cela doit fonctionner.
Je suis presque arriver à un bon résultat avec mes maigres connaissances, mais parfois sans savoir pourquoi, le code colle les valeurs n'importe ou :cry: Peu être qu'en vidant le presse papier à chaque fois cela irait mieux mais impossible de trouver un code pour système en 64 bits et le "Application.CutCopyMode = False" ne fait qu'arrêter le presse papier et non le vider...
Voici le code en intégrale mais ne vous moquer pas trop car c'est ma première véritable tentative en VBA :oops:

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
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
Sub surface()
 
    'Profil Fictif
 
    ActiveSheet.Unprotect
    Rows("4:4").Select
    Selection.EntireRow.Hidden = False
    If Range("T4").Value = "PF" Then
    Range("T4").Select
    Selection.Copy
    Range("Q458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("Q" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Range("X4").Select
    Selection.Copy
    Range("R458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("R" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Range("S458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("S" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    End If
 
   'Numéro de profil
 
    Range("K1").Select
    Selection.Copy
    Range("Q458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("Q" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
 
    'Surface déblais
 
    If Range("I4").Value = "" Then
    Range("X4").Select
    Selection.Copy
    Range("R458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("R" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    End If
    Range("I4").Select
    Selection.Copy
    Range("R458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("R" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
 
   'Surface Remblais
 
    If Range("P4").Value = "" Then
    Range("X4").Select
    Selection.Copy
    Range("S458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("S" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    End If
    Range("P4").Select
    Selection.Copy
    Range("S458").Select
    Selection.End(xlUp).Select
    Ligne = ActiveCell.Row
    Range("S" & Ligne + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Rows("4:4").Select
    Selection.EntireRow.Hidden = True
    Rows("2:3").Select
    Selection.EntireRow.Hidden = False
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 
   'Remise à zéro
 
    Range("B5:d50,J5:K50").Select
    Selection.ClearContents
    Range("B5").Select
    Application.CutCopyMode = False
 
    End Sub

je joint aussi le fichier ce sera peu être plus compréhensible :)
Désoler mais je ne trouve pas le truck pour mettre le code dans une fenêtre et je ne sais pas si mon fichier à passer :oops:

Citation:

parfois sans savoir pourquoi, le code colle les valeurs n'importe ou Peu être qu'en vidant le presse papier à chaque fois cela irait mieux

Non ce n'est probablement pas une question de vider le presse papier ou pas mais de réaliser le code en ciblant correctement les cellules sans passer par des "Select".

Ci-dessous ton code simplifié qui te permettra peut-être de mieux comprendre ce qui se passe

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
Sub surface()
 
'Désactiver la protection de la feuille
ActiveSheet.Unprotect
 
'Profil Fictif
If Range("T4").Value = "PF" Then '<-- si cellule T4 = "PF" alors
    Range("Q" & Rows.Count).End(xlUp).Offset(1, 0) = Range("T4") '<-- première cellule vide de la colonne Q = cellule T4
    Range("R" & Rows.Count).End(xlUp).Offset(1, 0) = Range("X4") '<-- première cellule vide de la colonne R = cellule X4
    Range("S" & Rows.Count).End(xlUp).Offset(1, 0) = Range("X4") '<-- première cellule vide de la colonne S = cellule X4
End If
 
'Numéro de profil
Range("Q" & Rows.Count).End(xlUp).Offset(1, 0) = Range("K1") '<-- première cellule vide de la colonne Q = cellule K1
 
'Surface déblais
If .Range("I4").Value = "" Then '<-- si cellule I4 est vide alors
    Range("R" & Rows.Count).End(xlUp).Offset(1, 0) = Range("X4") '<-- première cellule vide de la colonne R = cellule X4
Else
    Range("R" & Rows.Count).End(xlUp).Offset(1, 0) = Range("I4") '<-- sinon première cellule vide de la colonne R = cellule I4
End If
 
'Surface Remblais
If Range("P4").Value = "" Then '<-- si cellule P4 est vide alors
    Range("S" & Rows.Count).End(xlUp).Offset(1, 0) = Range("X4") '<-- première cellule vide de la colonne S = cellule X4
Else
    Range("S" & Rows.Count).End(xlUp).Offset(1, 0) = Range("P4") '<-- sinon première cellule vide de la colonne S = cellule P4
End If
 
'Remise à zéro
Range("B5:D50,J5:K50").ClearContents
 
'Réactiver la protection de la feuille
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 
End Sub

Citation:

Désoler mais je ne trouve pas le truck pour mettre le code dans une fenêtre

Tu sélectionnes ton code et tu cliques sur le bouton # que tu trouves dans le menu de mise en forme lorsque tu rédiges un message

24/06/2012, 19h19
dmoluc

Merci pour cette réponse rapide, le code fonctionne bien mais comme le mien il n'en fait qu'à sa tête : la colonne "Q" (N° de profil) aucun problème mais pour les deux autres, parfois c'est, d'autre fois deux lignes en dessous ou même aussi les deux valeurs décaler de plusieurs lignes 8O
C'est vraiment fiable le VBA ?
je trouvais sympa l'utilisation d'un bouton pour qui donne plus de souplesse qu'une formule qui sera appliquer qu'on le veuille ou non mais ce sera peu être la solution :cry:
Encore merci pour ton code si bien détaillé; je pense qu'il va m'aider pas mal dans mes travaux :ccool:
25/06/2012, 01h38
fring

Oui le VBA est fiable et non il n'en fait pas qu'à sa tête mais il fait ce qu'on lui demande de faire et c'est probablement là qu'est l'os, si tu poses mal tes conditions tu n'obtiens pas les résultats désirés.

Si tu essayais d'expliquer plus clairement ce que tu cherches à faire on pourra probablement t'aider d'avantage mais là, sans savoir la finalité du programme, il est difficile de dire ce qui coince.
25/06/2012, 07h49
dmoluc

Bonjour,
Dans le classeur que j'ai mis en pièce jointe, la feuille "Surface Rect" me permet de calculer les surfaces de déblais et de remblai d'un profil par coordonnées rectangulaire (c'est de la topographie) Une fois les surfaces d'un profil calculée je les stocke avec le N° du profil dans les colonnes Q,R et S afin de m'en resservir dans la feuille "cubature" et là il me faut bien une macro car avec une formule c'est impossible.
Comme je n'ai pas réussis à trouver la dernière valeur de la colonne "I" et aussi "P" en Vba, j'ai mis une formule dans les cellules I4 et P4 "=SI(SOMME(I5:I50)=0;"";ABS(RECHERCHE(9^9;I5:I50)))" comme cela je peu récupérer la valeur à une adresse fixe. Ensuite il y a des condition car je peu avoir une surface déblais et pas de remblais et vis-versas c'est pour ça que j'ai mis un if, then car si une des 2 cellules est vide je prend "0" comme valeur qui se trouve dans la cellule "X4" (toujours en copier coller car je ne sais pas faire autrement) j'ai aussi la condition que si la colonne "T" me renvoit en "T4" "PF", je colle les valeurs "PF" en colonne "Q" et "0" dans les colonnes "R et S" juste avant le N° de profil et ces deux surfaces.
Un peu laborieux comme explication mais la feuille n'est pas si simple qu'il y parait beaucoup de condition dans les formules pour que ça fonctionne correctement, mais encore merci pour votre aide...
25/06/2012, 16h15
dmoluc

1 pièce(s) jointe(s)

En fait maintenant ça fonctionne :ccool: merci pour ta macro "Fring" car si elle faisait des erreurs ce n'était pas de sa faute mais parce que j'avais laissé des données inscrite avec ma malheureuse macro :oops:
J'ai terminé le classeur et je vais essayé de le poster, s'il n'est pas trop gros, car ça peu peu être servir à quelqu'un s'il a quelques base en topographie.
Encore merci pour tout :ccool:
Le fichier a passé mais j'espère qu'il fonctionnera car je l'ai compresser à mort...