Modification macro ouverture et fermeture

smeto

XLDnaute Nouveau
Bonjour à tous,
je chercher à modifier le code ci-dessous pour pouvoir ouvrir et fermer le fichier Arbo automatiquement pendant l'exécution du code,
parce que dans le cas actuel je suis obligé de garder le fichier Arbo ouvert pour exécuter le code que j'ai sur EOTP, si non le code affiche erreur

Merci d'avance

VB:
Sub test()

Dim dl1 As Integer, dl2 As Integer, i As Integer

 Set arbo = Workbooks("Arbo.xlsx").Sheets("Sheet1")
 Set eotp = ThisWorkbook.Sheets("EOTP")

 dl1 = arbo.Range("A" & Rows.Count).End(xlUp).Row


  arbo.Range("B2:C" & dl1).Copy eotp.Range("A8")
  With eotp
    dl2 = eotp.Range("A" & Rows.Count).End(xlUp).Row
       .Range("A8:B8").Interior.ColorIndex = 4          'RGB(0, 255, 0)
  For i = 8 To dl2
    If .Range("B" & i) = "COMPTES TRANSITOIRES" Or .Range("B" & i) = "INTRA" Or .Range("B" & i) = "EXTRA" Then
       .Range("A" & i & ":B" & i).Interior.ColorIndex = 3      'RGB(0, 176, 240)
    End If
   
    If .Range("B" & i) = "COMPTE PROVISOIRE" Or .Range("B" & i) = "PRODUCTION" Or .Range("B" & i) = "AUTRES MATERIAUX" Or .Range("B" & i) = "MATOS" Or .Range("B" & i) = "ACHATS" Then
       .Range("A" & i & ":B" & i).Interior.ColorIndex = 8       'RGB(255, 51, 0)
    End If
  Next i
 End With
End Sub
 

Fichiers joints

ChTi160

XLDnaute Barbatruc
Bonjour smeto
Bonjour le Fil ,le Forum
une approche
les deux fichiers sont dans le même Dossier.
VB:
Sub Test()
Dim WkB_Cible As Workbook
Dim Chemin As String
Dim dl1 As Integer, dl2 As Integer, i As Integer
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path & "/Arbo.xlsx"
Set WkB_Cible = Workbooks.Open(Chemin)
 Set Ws_Arbo = WkB_Cible.Sheets("Sheet1")
 Set eotp = ThisWorkbook.Sheets("EOTP")
 With WkB_Cible
  With Ws_Arbo
 dl1 = .Range("A" & Rows.Count).End(xlUp).Row
   With .Range("B2:C" & dl1)
       .Copy eotp.Range("A8")
   End With
  End With
   .Close True
 End With
  With eotp
    dl2 = eotp.Range("A" & Rows.Count).End(xlUp).Row
       .Range("A8:B8").Interior.ColorIndex = 4          'RGB(0, 255, 0)
  For i = 9 To dl2
              StrColor = xlNone
    If .Range("B" & i) = "COMPTES TRANSITOIRES" Or .Range("B" & i) = "INTRA" Or .Range("B" & i) = "EXTRA" Then
              StrColor = 3      'RGB(0, 176, 240)
    ElseIf .Range("B" & i) = "COMPTE PROVISOIRE" Or .Range("B" & i) = "PRODUCTION" Or .Range("B" & i) = "AUTRES MATERIAUX" Or .Range("B" & i) = "MATOS" Or .Range("B" & i) = "ACHATS" Then
              StrColor = 8       'RGB(255, 51, 0)
    End If
           .Range("A" & i & ":B" & i).Interior.ColorIndex = StrColor
  Next i
 End With
              StrColor = xlNone
  Application.ScreenUpdating = True
End Sub

Sub efface()
Dim dl2 As Integer
 With Sheets("EOTP")
   dl2 = .Range("A" & .Rows.Count).End(xlUp).Row
    With .Range("A8:B" & dl2)
         .Interior.ColorIndex = xlNone
         .ClearContents
    End With
 End With
End Sub
jean marie
 
Dernière édition:

ChTi160

XLDnaute Barbatruc
Re
Question la Ligne 8 doit elle toujours être en Vert ?
le code ci dessus a été modifié.
jean marie
 
Dernière édition:

smeto

XLDnaute Nouveau
Bonjour CHTI160,
merci pour la modification,
pour répondre à votre question je dirais oui la ligne 8 doit être toujours en vert
 

smeto

XLDnaute Nouveau
Re CHTI160,
est ce que c'est possible de modifier dans le code une ligne pour cadrer le tableau comme je l'ai fait manuellement
et de colorer en Jaune toutes les cellules de la colonne B qui commence avec COMMERCE
 

Fichiers joints

smeto

XLDnaute Nouveau
Re CHTI160,
pour le mot commerce le code ne colore en jaune que les cellules qui contiennent exactement le mot commerce, alors qu'il doit colorer toutes les cellules qui commencent avec Commerce,
exemple Commerce international, commerce Interne...Ect
 

smeto

XLDnaute Nouveau
Bonjour Jean marie,
merci beaucoup, la nouvelle version marche très bien sauf que cette fois le code supprime les titres de la ligne 7, chose qui n'existait pas dans les autres versions
 

ChTi160

XLDnaute Barbatruc
Re
Tu remplaces la macro "efface"
par celle ci.
VB:
Sub efface()
Dim dl2 As Integer
 With Sheets("EOTP")
   dl2 = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'ici j'ai modifié "Plus 1"
    With .Range("A8:B" & dl2)
         .Interior.ColorIndex = xlNone
         .Borders.LineStyle = xlNone
         .ClearContents
    End With
 End With
End Sub
jean marie
 

smeto

XLDnaute Nouveau
Re,
cette fois ça fonctionné, entre autre fallait pas annuler cette partie du code ?? (parce que ça évite aussi le même problème)

'****************
efface
'****************

Merci beaucoup
 

Discussions similaires


Haut Bas