N
nilses
Guest
Renseignements & Conseils
Bonjour à tous,
Je me permets de vous solliciter, car vous êtes les dernières personnes à pourvoir répondre à mes questions. J’ai posté plusieurs questions sur différents forums en France et aux USA mais sans résultat. Je suis même allé à la FNAC mais aussi sans résultat !!!
Je n’ai trouvé personne pour répondre à cette question. La seule réponse est de passer par le mise en forme conditionnelle sans passer par le code VBA. Je souhaite faire de la mise en forme conditionnelle mais uniquement par VBA. Je récupère des données d’une table Access et je souhaite faire de la mise en forme conditionnelle automatique sans que la personne puisse taper une formule dans l’option mise en forme conditionnelle. Mon code ci-dessous marche mais il met en rouge que la case = DC ou la case = DHC. Je souhaite mettre en couleur la ligne entière jusqu'à la dernière cellule où se trouvent des données, je n’ai pas trouvé d’information sur ce sujet.
Voici le code que j’utilise pour mettre rouge par exemple une cellule contenant « DC » mais cela ne marche pas pour toute la ligne.
Set thisrange = Rg.Range("A4").CurrentRegion
For Each Cell In thisrange
If Cell.Value = "DC" Then
Cell.Select
With Selection
.Interior.ColorIndex = 3
End With
ElseIf Cell.Value = "VANDALISME" Then
Cell.Select
With Selection
.Interior.ColorIndex = 4
End With
End If
Next Cell
- J'ai un petit problème avec la procédure Sub Insérer_Image. L'image se charge à chaque fois lorsque j'ouvre mon fichier Excel. Si j'ouvre et je referme 4 fois mon fichier, j'aurais 4 fois la même image l'une sur l'autre. Comment faire pour vérifier si cette image existe dans ma feuille et si oui, l'image ne se charge pas .
Sub InsertPicture()
Dim Sh As Worksheet, Rg As Range, Image As Object
Set Sh = Worksheets("MySheet")
Set Rg = Sh.Range("A1")
With Rg
Largeur = Rg.Offset(, 1)(, Rg.Columns.Count).Left - Rg.Left
Hauteur = Rg.Offset(Rg.Rows.Count).Top - Rg(1).Top
Set Image = Sh.Pictures.Insert(ThisWorkbook.Path & "\Hello.gif")
With Image
.Left = Rg.Left
.Top = Rg.Top
.ShapeRange.ScaleHeight 0.045, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleWidth 0.24, msoFalse, msoScaleFromTopLeft
.Width = Largeur
.Height = Hauteur
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
.Locked = True 'or False
End With
End With
Set Rg = Nothing: Set Sh = Nothing: Set Image = Nothing
End Sub
Ma dernière question est la suivante. Si j’utilise tout ce code et que j’envoie le fichier Excel, Excel va garder le code dans son fichier et donc lorsqu’une personne va ouvrir ce fichier sur son ordinateur, Excel va vouloir chercher les données. Comment garder en mémoire les données et couper la liaison entre Access et Excel ?.
Voici le code que j’utilise dans son intégralité à titre d'information:
Sub CopyFromRecordset_DAO()
Dim Db1 As Database
Dim Rs1 As Recordset, Nb As Long
Dim Sh As Worksheet, Rg As Range, Nl As Range
Dim border As MsoLineStyle
border = msoLineSingle
Set Sh = Worksheets("MySheet")
With Sh
Set Rg = .Range("A4")
End With
Set Db1 = DBEngine.OpenDatabase(ThisWorkbook.Path & "\MyDataBase.mdb")
Set Rs1 = Db1.OpenRecordset("MyQuery", dbOpenTable)
Rg.CurrentRegion.Clear
If Rs1.EOF = False Then
Nb = Rs1.Fields.Count - 1
For a = 0 To Nb
Rg(, 1 + a) = Rs1.Fields(a).Name
Next
Rg.Resize(, Nb + 1).Font.Bold = True
Rg.Offset(1).CopyFromRecordset Rs1
Rg.CurrentRegion.EntireColumn.AutoFit
Rg.CurrentRegion.BorderAround border, xlHairline, 0
Rg.CurrentRegion.Borders.LineStyle = xlContinuous
With Worksheets("Feuille1").Range("B2:G2")
.Merge (Across)
.Value = "ça marche !!!"
.Borders.LineStyle = xlContinuous
.Font.Size = 14
.Font.Bold = True
End With
Worksheets("MySheet").Range("A4:IV4").HorizontalAlignment = xlHAlignCenter
Worksheets("MySheet").Range("A4:IV4").VerticalAlignment = xlVAlignCenter
Worksheets("MySheet").PageSetup.LeftMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.RightMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.TopMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.BottomMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.HeaderMargin = Application.CentimetersToPoints(0.5)
Worksheets("MySheet").PageSetup.FooterMargin = Application.CentimetersToPoints(0.5)
Worksheets("MySheet").PageSetup.PrintTitleRows = ActiveSheet.Rows("1:4").Address
Set thisrange = Rg.Range("A4").CurrentRegion
For Each Cell In thisrange
If Cell.Value = "DC" Then
Cell.Select
With Selection
.Interior.ColorIndex = 3
End With
ElseIf Cell.Value = "VANDALISME" Then
Cell.Select
With Selection
.Interior.ColorIndex = 4
End With
End If
Next Cell
Else
MsgBox "No Record !!"
End If
Set Rg = Nothing: Set Sh = Nothing
Rs1.Close: Db1.Close
Set Rs1 = Nothing: Set Db1 = Nothing
End Sub
Merci de votre aide
Nilses
Bonjour à tous,
Je me permets de vous solliciter, car vous êtes les dernières personnes à pourvoir répondre à mes questions. J’ai posté plusieurs questions sur différents forums en France et aux USA mais sans résultat. Je suis même allé à la FNAC mais aussi sans résultat !!!
Je n’ai trouvé personne pour répondre à cette question. La seule réponse est de passer par le mise en forme conditionnelle sans passer par le code VBA. Je souhaite faire de la mise en forme conditionnelle mais uniquement par VBA. Je récupère des données d’une table Access et je souhaite faire de la mise en forme conditionnelle automatique sans que la personne puisse taper une formule dans l’option mise en forme conditionnelle. Mon code ci-dessous marche mais il met en rouge que la case = DC ou la case = DHC. Je souhaite mettre en couleur la ligne entière jusqu'à la dernière cellule où se trouvent des données, je n’ai pas trouvé d’information sur ce sujet.
Voici le code que j’utilise pour mettre rouge par exemple une cellule contenant « DC » mais cela ne marche pas pour toute la ligne.
Set thisrange = Rg.Range("A4").CurrentRegion
For Each Cell In thisrange
If Cell.Value = "DC" Then
Cell.Select
With Selection
.Interior.ColorIndex = 3
End With
ElseIf Cell.Value = "VANDALISME" Then
Cell.Select
With Selection
.Interior.ColorIndex = 4
End With
End If
Next Cell
- J'ai un petit problème avec la procédure Sub Insérer_Image. L'image se charge à chaque fois lorsque j'ouvre mon fichier Excel. Si j'ouvre et je referme 4 fois mon fichier, j'aurais 4 fois la même image l'une sur l'autre. Comment faire pour vérifier si cette image existe dans ma feuille et si oui, l'image ne se charge pas .
Sub InsertPicture()
Dim Sh As Worksheet, Rg As Range, Image As Object
Set Sh = Worksheets("MySheet")
Set Rg = Sh.Range("A1")
With Rg
Largeur = Rg.Offset(, 1)(, Rg.Columns.Count).Left - Rg.Left
Hauteur = Rg.Offset(Rg.Rows.Count).Top - Rg(1).Top
Set Image = Sh.Pictures.Insert(ThisWorkbook.Path & "\Hello.gif")
With Image
.Left = Rg.Left
.Top = Rg.Top
.ShapeRange.ScaleHeight 0.045, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleWidth 0.24, msoFalse, msoScaleFromTopLeft
.Width = Largeur
.Height = Hauteur
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
.Locked = True 'or False
End With
End With
Set Rg = Nothing: Set Sh = Nothing: Set Image = Nothing
End Sub
Ma dernière question est la suivante. Si j’utilise tout ce code et que j’envoie le fichier Excel, Excel va garder le code dans son fichier et donc lorsqu’une personne va ouvrir ce fichier sur son ordinateur, Excel va vouloir chercher les données. Comment garder en mémoire les données et couper la liaison entre Access et Excel ?.
Voici le code que j’utilise dans son intégralité à titre d'information:
Sub CopyFromRecordset_DAO()
Dim Db1 As Database
Dim Rs1 As Recordset, Nb As Long
Dim Sh As Worksheet, Rg As Range, Nl As Range
Dim border As MsoLineStyle
border = msoLineSingle
Set Sh = Worksheets("MySheet")
With Sh
Set Rg = .Range("A4")
End With
Set Db1 = DBEngine.OpenDatabase(ThisWorkbook.Path & "\MyDataBase.mdb")
Set Rs1 = Db1.OpenRecordset("MyQuery", dbOpenTable)
Rg.CurrentRegion.Clear
If Rs1.EOF = False Then
Nb = Rs1.Fields.Count - 1
For a = 0 To Nb
Rg(, 1 + a) = Rs1.Fields(a).Name
Next
Rg.Resize(, Nb + 1).Font.Bold = True
Rg.Offset(1).CopyFromRecordset Rs1
Rg.CurrentRegion.EntireColumn.AutoFit
Rg.CurrentRegion.BorderAround border, xlHairline, 0
Rg.CurrentRegion.Borders.LineStyle = xlContinuous
With Worksheets("Feuille1").Range("B2:G2")
.Merge (Across)
.Value = "ça marche !!!"
.Borders.LineStyle = xlContinuous
.Font.Size = 14
.Font.Bold = True
End With
Worksheets("MySheet").Range("A4:IV4").HorizontalAlignment = xlHAlignCenter
Worksheets("MySheet").Range("A4:IV4").VerticalAlignment = xlVAlignCenter
Worksheets("MySheet").PageSetup.LeftMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.RightMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.TopMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.BottomMargin = Application.CentimetersToPoints(1)
Worksheets("MySheet").PageSetup.HeaderMargin = Application.CentimetersToPoints(0.5)
Worksheets("MySheet").PageSetup.FooterMargin = Application.CentimetersToPoints(0.5)
Worksheets("MySheet").PageSetup.PrintTitleRows = ActiveSheet.Rows("1:4").Address
Set thisrange = Rg.Range("A4").CurrentRegion
For Each Cell In thisrange
If Cell.Value = "DC" Then
Cell.Select
With Selection
.Interior.ColorIndex = 3
End With
ElseIf Cell.Value = "VANDALISME" Then
Cell.Select
With Selection
.Interior.ColorIndex = 4
End With
End If
Next Cell
Else
MsgBox "No Record !!"
End If
Set Rg = Nothing: Set Sh = Nothing
Rs1.Close: Db1.Close
Set Rs1 = Nothing: Set Db1 = Nothing
End Sub
Merci de votre aide
Nilses
