J'essaie d'ajouter une forme sur un emplacement de cellule spécifique, mais je ne peux pas ajouter la forme à l'emplacement souhaité pour une raison quelconque. Vous trouverez ci-dessous le code que j'utilise pour ajouter la forme:
Cells(milestonerow, enddatecellmatch.Column).Activate Dim cellleft As Single Dim celltop As Single Dim cellwidth As Single Dim cellheight As Single cellleft = Selection.Left celltop = Selection.Top ActiveSheet.Shapes.AddShape(msoShapeOval, cellleft, celltop, 4, 10).Select
6 Réponses :
Cela semble fonctionner pour moi. J'ai ajouté les relevés de débogage à la fin pour afficher si la forme Pour cela, j'avais sélectionné la cellule .top et .left est égale à la cellule .top et et Valeurs . C2 . 
J'ai ajouté votre section de débogage et la forme et la cellule gauche et les points de haut en haut étaient les mêmes, donc je ne savais pas pourquoi cela ne fonctionnait pas. J'ai sauvegardé le classeur, fermé Excel, puis le rouvert puis le rouvert, puis cela a bien fonctionné, alors ne savez pas vraiment quel problème était, mais merci de réponse.
Le problème était votre zoom n'était pas à 100%. Tout changement de zoom et ce code ne fonctionnera pas.
J'ai découvert que ce problème est causé par un bogue qui ne se produit que lorsque le niveau de zoom n'est pas de 100%. La position de la cellule est informée de manière incorrecte dans ce cas.
Une solution à utiliser est de changer de zoom sur 100%, de régler les positions, puis de retourner sur le zoom d'origine. Vous pouvez utiliser Application.Screenupdature pour éviter tout scintillement. P>
Dim oldZoom As Integer oldZoom = Wn.Zoom Application.ScreenUpdating = False Wn.Zoom = 100 'Set zoom at 100% to avoid positioning errors cellleft = Selection.Left celltop = Selection.Top ActiveSheet.Shapes.AddShape(msoShapeOval, cellleft, celltop, 4, 10).Select Wn.Zoom = oldZoom 'Restore previous zoom Application.ScreenUpdating = True
Mon idée est au lieu de changer le zoom, vous pouvez ajouter une boucle rapide pour chaque rangée jusqu'à la ligne où la cellule est.
et ajouter les sommets de chaque ligne,
quelque chose comme et la hauteur de la dernière cellule pour dimensionnement.
Le problème est que lorsque le zoom n'est pas à 100%, le C.Top que vous obtenez est faux, de sorte que cela ne fonctionnera pas. En outre, cela prendrait beaucoup plus de temps que de simplement changer le zoom ...
Essayez ce code (en deux parties) Sub MOVETOTATARGET () DIM CRANGE AS RETOURNE SET CRANGE = ACTIVECELL DAY DLEFT AS Double, DTOP comme Double dleft = Crange.Offset (0, 1) .left + (Crange.Width / 2) '' - ActiveWindow.Vissiblerange.left + actifwindow.left
Je pense que Microsoft a corrigé ce bogue, car il ne se produit plus plus. Je viens de tester et il semble que les formes soient maintenant positionnées là où elles devraient.
Public Sub MoveToTarget()
Dim cRange As Range
Set cRange = ActiveCell
Dim dLeft As Double, dTop As Double
dLeft = cRange.Offset(0, 1).Left + (cRange.Width / 2) ' - ActiveWindow.VisibleRange.Left + ActiveWindow.Left
If dLeft > Application.Width Then dLeft = cRange.Offset(0, -10).Left
dLeft = dLeft + Application.Left
'.Top = CommandBars("Ribbon").Height / 2
dTop = cRange.Top '(CommandBars("Ribbon").Height / 2) + cRange.Top ' cRange.Top ' - ActiveWindow.VisibleRange.Top - ActiveWindow.Top
If dTop > Application.Height Then dTop = cRange.Offset(-70, 0)
'dTop = dTop + Application.Top
ActiveSheet.Shapes.AddShape(msoShapeOval, dLeft, dTop, 200, 100).Select
End Sub
Réponses montrant simplement que le code n'est pas très bon. Envisagez de donner des informations pour enseigner à la personne qui a posté la question.
Je teste avec Office 365 64 Bit, Windows 10, et on dirait que le bogue persiste. En outre, je le vois même lorsque le zoom est de 100%.
Ma solution consistait à placer une forme d'échantillon cachée sur la feuille. Dans mon code, je copie l'échantillon, puis sélectionnez la cellule que je veux placer dans et coller. Il atterrit toujours exactement dans le coin supérieur gauche de cette cellule. Vous pouvez ensuite le rendre visible et la positionner par rapport à son propre haut et à gauche. P>
dim shp as shape
set shp = activesheet.shapes("Sample")
shp.copy
activesheet.cells(intRow,intCol).select
activesheet.paste
'after a paste, the selection is what was pasted
with selection
.top = .top + 3 'position it relative to where it thinks it is
end with
J'ai eu cette erreur de travail dans l'Excel 2019. J'ai découvert que la modification des paramètres d'affichage de la meilleure apparence à la compatibilité a résolu le problème. Je partage ceci au cas où quelqu'un a le même problème.
Le code ci-dessus fonctionne absolument ok pour moi.
.Activate en première ligne n'est pas nécessaire que cela équivaut à la sélection, alors ... Vous devez le vérifier. Ou simplement changer.ACtivate dans. Sélectionnez en première ligne.J'ai le même problème. Il y a une petite différence entre .Cell.left et la vraie position d'une forme. Ce "bogue" ne se produit que sur Excel 2007. On Excel 2003, le code VBA fonctionne bien. En 2010, je ne sais pas. J'essaie le débogage.print mais je ne vois aucun effet.
Utilisez-vous un zoom différent de 100%? J'ai découvert une erreur de dessin pour les positions de forme lors de l'utilisation de zoom. (Testé sur Excel 2016)