aide macro déplacer hyperlien si

andrekn13

XLDnaute Occasionnel
Bonjour
Je ne trouve pas de solution à ce que je voudrais obtenir. Mes connaissances
étant limitées. A la base mon bouton " synthèse" récapitule mon tableau, et en colonne A le N° de facture ( correspondant aussi à mon onglet), mon bouton " lien hypertexte" en colonne K correspond aux noms d' onglets.
Je voudrais en fait que ce bouton "lien hypertexte" puisse se mettre en colonne A seulement si le lien correspond BIEN au N° de facture, s'il y a problème , il reste en colonne K pour analyse
 

Pièces jointes

  • pour internet.xlsm
    103 KB · Affichages: 111
  • pour internet.xlsm
    103 KB · Affichages: 126
  • pour internet.xlsm
    103 KB · Affichages: 123

Yaloo

XLDnaute Barbatruc
Re : aide macro déplacer hyperlien si

Re,

Pour les onglets, c'est normal puisque lorsque tu lances la macro Load_Demandes, après l'ouverture de l'UserForm2 tu as cette ligne
ActiveWindow.DisplayWorkbookTabs = False
cela te cache les onglets. Soit tu remplaces False par True soit tu supprimes complètement cette ligne, qui n'a rien à voir avec l'envoi de données.

Pour transformer le devis en facture, à mon sens :

- Tu copies la feuille DEVIS dans le classeur FACTURE.
- Tu copies ton N° de facture (Num_Fact) dans la feuille ajoutée.
- Tu renommes ta feuille avec ton N° de facture
- Tu incrémente ton N° de facture (Num_Fact)
- Tu fermes DEVIS
- Tu imprimes ta Facture.

Avec quelques chose comme ça (à mettre dans le fichier FACTURE mais à lancer avec un bouton dans DEVIS) :
VB:
Sub Transfert_devis()
    ActiveSheet.Move After:=Workbooks("BASE FACT.xlsm").Sheets(Sheets.Count)
    Range("H17").FormulaR1C1 = [Num_Fact]
    ActiveSheet.Name = [Num_Fact]
    [Num_Fact] = [Num_Fact] + 1
    Windows("DEVIS ORIGINAL.xlsm").Activate
    ActiveWorkbook.Save
    ActiveWindow.Close
End Sub

A+

Martial
 

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

Bonjour
Encore merci pour hier
j'ai donc tout réadapter sur mes originaux et c nickel
pour la dernière étape j' ai repris la base de laacro juste en haut :
Sub Transfert_devis()

ActiveSheet.Copy After:=Workbooks("BASE FACT.xlsm").Sheets(Sheets.Count)

'recupération du numéro de devis sur h19
Range("H19") = Range("H17")

'Range("H17").FormulaR1C1 = [Num_Fact] + 1
Range("h17").FormulaR1C1 = Year(Now) & Format(Range("Num_Fact") + 1, "000")
Range("h18") = Format(Now, "d-mmm-yy")

Range("G17") = Sheets("D-fact froid").Range("G17")
Range("G19") = Sheets("D-fact froid").Range("G19")
'renommer onglet avec numero facture
ActiveSheet.Name = Format(Range("Num_Fact") + 1, "000")
' APPELATION DEVIS CLIM EN FACTURE
ActiveSheet.Shapes.Range(Array("Round Diagonal Corner Rectangle 5")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "FACTURE "
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 9). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 9).Font
.Bold = msoTrue
.Caps = msoNoCaps
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Shadow.Type = msoShadow21
.Shadow.Visible = msoTrue
.Shadow.Style = msoShadowStyleOuterShadow
.Shadow.Blur = 6.2992125984
.Shadow.OffsetX = 0.3292235064
.Shadow.OffsetY = 3.1323524264
.Shadow.RotateWithShape = msoTrue
.Shadow.ForeColor.RGB = RGB(0, 0, 0)
.Shadow.Transparency = 0.6999999881
.Shadow.Size = 100
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent6
.Fill.ForeColor.TintAndShade = 0.1000000238
.Fill.ForeColor.Brightness = 0
.Fill.BackColor.ObjectThemeColor = msoThemeColorAccent6
.Fill.BackColor.TintAndShade = 0.1000000238
.Fill.BackColor.Brightness = 0
.Fill.TwoColorGradient msoGradientHorizontal, 3
.Size = 20
.Line.Visible = msoFalse
.Name = "+mn-lt"
.Spacing = 0
End With

ATTENTION A PARTIR D' ICI C'EST DES ESSAIS EN '

'For i = 7 To Sheets.Count




'changement de devis en facture
' Sheets("D-FACT FROID").Select
' Selection.Copy
'Sheets("214").Select
'ActiveSheet.Paste
'changement N° de devis en suite devis
'Sheets("D-FACT FROID").Select
' Range("G19").Select
' Application.CutCopyMode = False
'Selection.Copy
'For i = 7 To Sheets.Count
'Sheets("i").Select
' Sheets(Sheets.Count).Select
'Range("G19").Select
' ActiveSheet.Paste
' ActiveSheet.Name = [Num_Fact]
' [Num_Fact] = [Num_Fact] + 1
'Windows("BASE DEVIS.xlsm").Activate
' ActiveWorkbook.Save
' ActiveWindow.Close


' Rows("48:57").Select
'Selection.RowHeight = 10
' ActiveCell.Rows("1:10").EntireRow.Select
' With Selection.Font
' .Name = "Calibri"
' .Size = 9
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ThemeColor = xlThemeColorLight1
' .TintAndShade = 0
' .ThemeFont = xlThemeFontMinor
' End With
' Range("A48:A57") = Sheets("D-fact froid").Range("A48:A57")
'Range("A48:A57").CopyMode.Range("A48:A57").Sheets ("D-fact froid")

' Range("48:57") = Sheets("D-FACT FROID").Rows("48:48")


'changement du texte en bas du devis passé en facture
Sheets("D-FACT FROID").Select
ActiveCell.Rows("1:10").EntireRow.Select
Selection.Copy
With SheetsName("Num_Fact") + 1, "000").Select
'With SheetsName = Format(Range("Num_Fact") + 1, "000").Select
'Sheets("336").Select
ActiveCell.Offset(-6, 0).Rows("1:1").EntireRow.Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=6

End WiTH
End Sub

ET LA DERNIERE COMMANDE QUE JE TE REPRENDS:
'changement du texte en bas du devis passé en facture
Sheets("D-FACT FROID").Select
ActiveCell.Rows("1:10").EntireRow.Select
Selection.Copy
With SheetsName("Num_Fact") + 1, "000").Select
'With SheetsName = Format(Range("Num_Fact") + 1, "000").Select
JE NE TROUVE PAS LA BONNE SYNTAXE, l' idée c' est que comme il n' accepte pas de faire Range (a48àA57)=comme D-Fact froid
c' est de faire un copier coller qui marche, et donc le coller sur la feuille qui correspond à ("Num_Fact") + 1
c'est trop bête tout à marché jusqu'à cette dernière étape !
 

Yaloo

XLDnaute Barbatruc
Re : aide macro déplacer hyperlien si

Bonjour André,

Pour copier un ensemble de ligne vers un autre, il faut faire :

ActiveSheet.Rows("1:10").Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Rows("1:10")
On copie les lignes de 1 à 10 de la feuille active (il faut se trouver sur la feuille devis) dans le classeur qui contient la macro dans la dernière feuille aux lignes de 1 à 10


Toute ta macro me parait bien compliquée.

Si c'est plus simple pour toi, tu peux, peut-être, copier tes données de DEVIS (comme ci-dessus) dans ta feuille FACTURE puis lancer ta macro de validation de facture, de façon à incrémenter ton N° de facture et créer ta facture dans ton fichier.

A+

Martial
 

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

ça marche pas
jcmprends pas je ne sais pas si c' est du au chgt de format ( hauteur le ligne ou taille police à 9)
 

Pièces jointes

  • pb bas.xlsx
    123.4 KB · Affichages: 107
  • pb bas.xlsx
    123.4 KB · Affichages: 116
  • pb bas.xlsx
    123.4 KB · Affichages: 117

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

voici la macro propre
Sub Transfert_devis()

ActiveSheet.Copy After:=Workbooks("BASE FACT.xlsm").Sheets(Sheets.Count)

'recupération du numéro de devis sur h19
Range("H19") = Range("H17")
Range("h17").FormulaR1C1 = Year(Now) & Format(Range("Num_Fact") + 1, "000")
Range("h18") = Format(Now, "d-mmm-yy")
Range("G17") = Sheets("D-fact froid").Range("G17")
Range("G19") = Sheets("D-fact froid").Range("G19")
'changement du bas de feuilles des clauses
ActiveSheet.Rows("50:60").Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Rows("50:60")

'renommer onglet avec numero facture
ActiveSheet.Name = Format(Range("Num_Fact") + 1, "000")

' APPELATION DEVIS CLIM EN FACTURE
ActiveSheet.Shapes.Range(Array("Round Diagonal Corner Rectangle 9")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "FACTURE "
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 9). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 9).Font
.Bold = msoTrue
.Caps = msoNoCaps
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Shadow.Type = msoShadow21
.Shadow.Visible = msoTrue
.Shadow.Style = msoShadowStyleOuterShadow
.Shadow.Blur = 6.2992125984
.Shadow.OffsetX = 0.3292235064
.Shadow.OffsetY = 3.1323524264
.Shadow.RotateWithShape = msoTrue
.Shadow.ForeColor.RGB = RGB(0, 0, 0)
.Shadow.Transparency = 0.6999999881
.Shadow.Size = 100
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent6
.Fill.ForeColor.TintAndShade = 0.1000000238
.Fill.ForeColor.Brightness = 0
.Fill.BackColor.ObjectThemeColor = msoThemeColorAccent6
.Fill.BackColor.TintAndShade = 0.1000000238
.Fill.BackColor.Brightness = 0
.Fill.TwoColorGradient msoGradientHorizontal, 3
.Size = 20
.Line.Visible = msoFalse
.Name = "+mn-lt"
.Spacing = 0
End With
End Sub

ci joint les 2 onglets dans le meme fichier....
 

Pièces jointes

  • pb bas.xlsx
    147.6 KB · Affichages: 115
  • pb bas.xlsx
    147.6 KB · Affichages: 116
  • pb bas.xlsx
    147.6 KB · Affichages: 126

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

Bonjour encore une fois , à force de chercher voici comment j'ai trouvé :
Sub Transfert_devisCLIM()

ActiveSheet.Copy After:=Workbooks("BASE FACT.xlsm").Sheets("A-FACT CLIM")

'recupération du numéro de devis sur h19
Range("H19") = Range("H17")
Range("h17").FormulaR1C1 = Year(Now) & Format(Range("Num_Fact") + 1, "000")
Range("h18") = Format(Now, "d-mmm-yy")
Range("G17") = Sheets("D-fact froid").Range("G17")
Range("G19") = Sheets("D-fact froid").Range("G19")
'changement du bas de feuilles des clauses
Range("A46") = Sheets("A-FACT CLIM").Range("A46")
Range("A47") = Sheets("A-FACT CLIM").Range("A47")
Range("A48") = Sheets("A-FACT CLIM").Range("A48")
Range("A49") = Sheets("A-FACT CLIM").Range("A49")
Range("A50") = Sheets("A-FACT CLIM").Range("A50")
Range("A51") = Sheets("A-FACT CLIM").Range("A51")
Range("A52") = Sheets("A-FACT CLIM").Range("A52")
Range("A53") = Sheets("A-FACT CLIM").Range("A53")
Range("A54") = Sheets("A-FACT CLIM").Range("A54")
Range("A55") = Sheets("A-FACT CLIM").Range("A55")
Range("A56") = Sheets("A-FACT CLIM").Range("A56")
Range("A57") = Sheets("A-FACT CLIM").Range("A57")
Range("E49").ClearContents
Range("E49").Clear
Range("E49").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'renommer onglet avec numero facture
ActiveSheet.Name = Format(Range("Num_Fact") + 1, "000")
' APPELATION DEVIS CLIM EN FACTURE
En conclusion tout fonctionne ! Même en recreant les Userform avec les mêmes codes , juste le chemin d' acces qui renvoie à :
With Workbooks("BASE FACT.xlsm").Sheets("Paramètres")
Car pour remplir la fiche client ta solution en passant par macro "load" marchait, mais pour remplir chaque ligne du tableau la liste des articles, impossible. En ayant chaque classeur ses userform mais avec la même base de données tout est rentré dans l' ordre.
( dailleurs si tu as une solution pour que je puisse utiliser la molette de défilement à travers la boite de dialogue, j' ai rien trouvé sur le net )
En conclusion un grand merci encore une fois.
 

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

je me doutais bien que si tu n' avais pas trouvé c'est qu'il y avait une très bonne raison ....!!!!
j'ai cherché au début du côté des codes vba
puis du côté modules liés à excel 2010 ( vb7) , là plus intérréssant : problèmes de compatibilités de version
et du côté microsoft : c' est encore pire !
en fait vb7 n' intègre pas la DLL et , à moins d' être programmeur style : Téléchargement de UTILISER LA ROULETTE DANS VB6 IDE (ADDIN)
ou https://www.excel-downloads.com/threads/molette-inactive-dans-le-code-sous-vba.20965/
le intellipoint 4.12 version française n' est plus compatible avec nos windows à jour ( j'ai la version 9)
en résumé j' ai le même problème que Comment récupérer la molette de la souris dans l'éditeur ? mais j' ai pas compris sa solution que j' ai éssayé
C' est toujours pareil, je crois que se sera pas long à faire une petite recherche , puis , PAF ! c' est un labyrinthe !
Enfin c' était pour te réconforter !!!!
A bientôt
 

Yaloo

XLDnaute Barbatruc
Re : aide macro déplacer hyperlien si

Salut André,

Merci de me réconforter, mais je peux très bien vivre sans avoir la roulette dans VBA :p.

J'ai regardé les liens que tu proposes dans ton post, il me semble qu'ils sont tous pour une version antérieure et non celle fournie avec Excel 2010. Dommage !!!!

A+

Martial
 

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

Je m'en doute bien, que tu peux vivre sans. C' était un tout petit plus. mais la curiosité m'a ratrappé ! c' est pour cela que j'ai créé un nouveau post, beaucoup plus pour comprendre cette curiosité : tout le monde s' est cassé les dents sur VB6 et sur VB7 , le désert total , même sur le net. ou j' ai loupé le "truc" .
 

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

Hé Bé !
j'ai reçu une solution qui remplace largement la roulette : à chaque clic droit , me fait défilé suivant mon incrémentation, ma liste.
Dans mon userform, ma liste contient 13 lignes et bien à chaque clic, je passe au 13 lignes suivantes.
a rajouter à la suite des codes de l' userform en question
Private Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim v As Byte
v = 13 'pas de défilement
With ListBox1
.TopIndex = IIf(b = False, .TopIndex + v, IIf((.TopIndex - v) >= 0, .TopIndex - v, 0))
If (.TopIndex + v) > .ListCount Then
b = True
ElseIf (.TopIndex + v) <= v Then b = False
End If
End With
End Sub
et marche nickel !
 

andrekn13

XLDnaute Occasionnel
Re : aide macro déplacer hyperlien si

bonjour
je reviens vers vous pour une petite aide en urgence
Suite ordi HS, j' ai besoin suivant ordi de faire une macro qui me permet de faire un pdf sur le bureau suivant l' ordi que j' utilise, sans à chaque fois changer l' adresse
Sub pdf()

Dim Fichier As String
Dim X As String
Dim Y As String
Dim Z As String

X = Range("E45").Value
Y = Range("E11").Value
Z = Range("H17").Value
Fichier = Z & " - " & Y & " - " & X & " € "

'sur ordi tour hs''ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\AK FROID\Desktop\COMPTA2013\LISTE FACTURES\" & Fichier, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, _
OpenAfterPublish:=False'

'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\HP AK FROID\Desktop\" & Fichier, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, _
OpenAfterPublish:=False'

'ORDI SAMSUNG'
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\AK\Desktop\" & Fichier, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, _
OpenAfterPublish:=False '


End Sub
MERCI ENCORE BEAUCOUP
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 886
Membres
101 830
dernier inscrit
sonia poulaert