Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 reduire le code

B

BIL boud

XLDnaute Occasionnel
bonjour

jai mis un code qui recupere des donnéee a partire dun autre fichier, apres la premiere importation il fait la mise a jours sans importer a nouveaux c que on a deja importe

le code fonction bien mais je souhaiterais le reduire si ya moyen

merci de votre aide

voici le code

VB: 
Sub Feuil_1(wsh0, test0, last0)



a = Workbooks(wb1).Worksheets("NEW_VB_config").Range("o2:o12") 'nom des 11 feuilles


For f = 1 To 11                 'boucle sur les feuilles
If a(f, 1) <> "" And a(f, 1) = wsh0 Then
   derlin = Workbooks(wb1).Worksheets(wsh0).Range("a65000").End(xlUp).row ' derniere ligne de la feuille (wsh1) de classeur omega1
   derlavl = Workbooks(wb).Worksheets(wsh).Range("c65000").End(xlUp).row
  
   If derlin <> 1 Then
Application.StatusBar = "Debut de test iOMEGA_1"
    'test ligne
    derliac0 = Workbooks(wb).Worksheets(wsh0).Range("an65000").End(xlUp).row
    For i2 = 2 To derliac0
     If Workbooks(wb).Worksheets(wsh0).Cells(i2, 40) = "OMEGA 1" Then
       test0 = Workbooks(wb).Worksheets(wsh0).Cells(i2, 40).row
     End If
    Next i2
  
  
   If test0 <> "" And derlin > test0 Then
     n2 = derlin - test0
     Workbooks(wb).Worksheets(wsh0).Rows(test0 + 1).Resize(n2).Insert
   ElseIf test0 = "" And derlin >= 2 Then
   Workbooks(wb).Worksheets(wsh0).Rows(2).Resize(derlin - 1).Insert
   End If
  'fin tets

Application.StatusBar = "premiere importation d'activites iOMEGA_1"
If test0 = "" Then ' premiere importation
      For i = derlin To 2 Step -1
      Workbooks(wb).Worksheets(wsh0).Cells(i, 40) = "OMEGA 1"
              For iavl = derlavl To 2 Step -1
                For j = 1 To 5000
                If Workbooks(wb1).Worksheets(wsh0).Cells(i, j) <> "" Then
                 If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
                  Workbooks(wb).Worksheets(wsh0).Cells(i, j) = Workbooks(wb1).Worksheets(wsh0).Cells(i, j)
                 End If
                 End If
                Next j
              Next iavl
              For i3 = 2 To derlin
              last0 = Workbooks(wb).Worksheets(wsh0).Range("a" & i3).row + 1
              Next i3
      Next i

Application.StatusBar = "fin de premiere importation iOMEGA_1"

ElseIf test0 = derlin Then  'soit si on a rajoute des lignes a la BDD source soit yavait pas de modif dans la BDD source
Application.StatusBar = "Decalage iOMEGA_1"
        'decaler les données existantes deja en fonctio de decalage de fichier sources
            
            For ii = 2 To derlin
             For i = 2 To derlin
              If Workbooks(wb).Worksheets(wsh0).Cells(ii, 1) <> "" Then
              For iavl = derlavl To 2 Step -1
              If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
               If Workbooks(wb1).Worksheets(wsh0).Cells(i, 1) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 1) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 5) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 5) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 6) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 6) Then
                lig1 = Workbooks(wb1).Worksheets(wsh0).Cells(i, 1).row
                lig2 = Workbooks(wb).Worksheets(wsh0).Cells(ii, 1).row
                If lig1 < lig2 Then
                Workbooks(wb).Worksheets(wsh0).Rows(ii).Cut Workbooks(wb).Worksheets(wsh0).Rows(lig1)
                End If
                End If
                End If
                Next iavl
              End If
              
              Next i
            Next ii
Application.StatusBar = "Decalage_2 iOMEGA_1"
            For ii = derlin To 2 Step -1
             For i = derlin To 2 Step -1
             If Workbooks(wb).Worksheets(wsh0).Cells(ii, 1) <> "" Then
             For iavl = derlavl To 2 Step -1
              If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
               If Workbooks(wb1).Worksheets(wsh0).Cells(i, 1) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 1) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 5) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 5) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 6) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 6) Then
                lig1 = Workbooks(wb1).Worksheets(wsh0).Cells(i, 1).row
                lig2 = Workbooks(wb).Worksheets(wsh0).Cells(ii, 1).row
                If lig1 > lig2 Then
                Workbooks(wb).Worksheets(wsh0).Rows(ii).Cut Workbooks(wb).Worksheets(wsh0).Rows(lig1)
                End If
              End If
              End If
              Next iavl
              End If
              Next i
            Next ii

Application.StatusBar = "Importation de nouvelles activites iOMEGA_1"
           For i = derlin To 2 Step -1
           Workbooks(wb).Worksheets(wsh0).Cells(i, 40) = "OMEGA 1"
           'apres le decalage, importer les données rajoutées dans les fichier sources
           For iavl = derlavl To 2 Step -1
           If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
             If Workbooks(wb1).Worksheets(wsh0).Cells(i, 1) <> Workbooks(wb).Worksheets(wsh0).Cells(i, 1) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 5) <> Workbooks(wb).Worksheets(wsh0).Cells(i, 5) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 6) <> Workbooks(wb).Worksheets(wsh0).Cells(i, 6) Then
                 For j = 1 To 5000
                 If Workbooks(wb1).Worksheets(wsh0).Cells(i, j) <> "" Then
                  Workbooks(wb).Worksheets(wsh0).Cells(i, j) = Workbooks(wb1).Worksheets(wsh0).Cells(i, j)
                  End If
                 Next j
              End If
             End If
            Next iavl
            Next i
            
            For i3 = 2 To derlin
            last0 = Workbooks(wb).Worksheets(wsh0).Range("a" & i3).row + 1
            Next i3
            Application.StatusBar = "Fin de decalage"
            Application.StatusBar = "Importation de nouvelles activites"
            

ElseIf test0 < derlin Then
Application.StatusBar = "Decalage iOMEGA_1"

           For ii = derlin To 2 Step -1
             For i = derlin To 2 Step -1
             If Workbooks(wb).Worksheets(wsh0).Cells(ii, 1) <> "" Then
             For iavl = derlavl To 2 Step -1
              If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
               If Workbooks(wb1).Worksheets(wsh0).Cells(i, 1) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 1) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 5) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 5) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 6) = Workbooks(wb).Worksheets(wsh0).Cells(ii, 6) Then
                lig1 = Workbooks(wb1).Worksheets(wsh0).Cells(i, 1).row
                lig2 = Workbooks(wb).Worksheets(wsh0).Cells(ii, 1).row
                If lig1 > lig2 Then
                Workbooks(wb).Worksheets(wsh0).Rows(ii).Cut Workbooks(wb).Worksheets(wsh0).Rows(lig1)
                End If
              End If
              End If
              Next iavl
              End If
              Next i
            Next ii

Application.StatusBar = "Importation de nouvelles activites iOMEGA_1"
           For i = derlin To 2 Step -1
           Workbooks(wb).Worksheets(wsh0).Cells(i, 40) = "OMEGA 1"
           'apres le decalage, importer les données rajoutées dans les fichier sources
           For iavl = derlavl To 2 Step -1
           If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
             If Workbooks(wb1).Worksheets(wsh0).Cells(i, 1) <> Workbooks(wb).Worksheets(wsh0).Cells(i, 1) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 5) <> Workbooks(wb).Worksheets(wsh0).Cells(i, 5) And Workbooks(wb1).Worksheets(wsh0).Cells(i, 6) <> Workbooks(wb).Worksheets(wsh0).Cells(i, 6) Then
                 For j = 1 To 5000
                 If Workbooks(wb1).Worksheets(wsh0).Cells(i, j) <> "" Then
                  Workbooks(wb).Worksheets(wsh0).Cells(i, j) = Workbooks(wb1).Worksheets(wsh0).Cells(i, j)
                  End If
                 Next j
              End If
            End If
            Next iavl
            Next i
            
            For i3 = 2 To derlin
            last0 = Workbooks(wb).Worksheets(wsh0).Range("a" & i3).row + 1
            Next i3
            Application.StatusBar = "Fin de decalage"
            Application.StatusBar = "Importation de nouvelles activites"
            
Application.StatusBar = "Fin d'importation iOMEGA_1"
ElseIf test0 > derlin Then ' si on a supprime des lignes dans la BDD source

For i4 = 2 To test0
Application.StatusBar = "Decalage iOMEGA_1"
            'decaler les données existantes deja en fonctio de numero de ligne de fichier sources
            For ii2 = 2 To test0
             If Workbooks(wb).Worksheets(wsh0).Cells(ii2, 1) <> "" Then
             For iavl = derlavl To 2 Step -1
              If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i4, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
              If Workbooks(wb1).Worksheets(wsh0).Cells(i4, 1) = Workbooks(wb).Worksheets(wsh0).Cells(ii2, 1) And Workbooks(wb1).Worksheets(wsh0).Cells(i4, 5) = Workbooks(wb).Worksheets(wsh0).Cells(ii2, 5) And Workbooks(wb1).Worksheets(wsh0).Cells(i4, 6) = Workbooks(wb).Worksheets(wsh0).Cells(ii2, 6) Then
                lig1 = Workbooks(wb1).Worksheets(wsh0).Cells(i4, 1).row
                Workbooks(wb).Worksheets(wsh0).Rows(ii2).Cut Workbooks(wb).Worksheets(wsh0).Rows(lig1)
              End If
             End If
             Next iavl
             End If
            Next ii2

Application.StatusBar = "Importation de nouvelles activites iOMEGA_1"

           'apres le decalage, importer les données rajoutées dans les fichier sources
           For iavl = derlavl To 2 Step -1
           If LCase(ch_sans_accent(Workbooks(wb1).Worksheets(wsh0).Cells(i4, 4))) = LCase(ch_sans_accent(Workbooks(wb).Worksheets(wsh).Cells(iavl, 3))) Then
            If Workbooks(wb1).Worksheets(wsh0).Cells(i4, 1) <> Workbooks(wb).Worksheets(wsh0).Cells(i4, 1) And Workbooks(wb1).Worksheets(wsh0).Cells(i4, 5) <> Workbooks(wb).Worksheets(wsh0).Cells(i4, 5) And Workbooks(wb1).Worksheets(wsh0).Cells(i4, 6) <> Workbooks(wb).Worksheets(wsh0).Cells(i4, 6) Then
                 For j = 1 To 5000
                 If Workbooks(wb1).Worksheets(wsh0).Cells(i4, j) <> "" Then
                  Workbooks(wb).Worksheets(wsh0).Cells(i4, j) = Workbooks(wb1).Worksheets(wsh0).Cells(i4, j)
                  End If
                 Next j
             End If
            End If
            Next iavl
            
Next i4
            
            
            der = Workbooks(wb1).Worksheets(wsh0).Range("a65000").End(xlUp).row 'derniere ligne de la BDD imoga6
            For u = 2 To der
            Workbooks(wb).Worksheets(wsh0).Cells(u, 40) = "OMEGA 1"
            Next u
          
            prem = Workbooks(wb).Worksheets(wsh0).Range("an" & test0).End(xlDown).row
            w = prem - 1 - der
            Workbooks(wb).Worksheets(wsh0).Rows(der + 1).Resize(w).Delete
          
            For i5 = 2 To derlin ' definir la derniere ligne occupée par la BDD 1
            last0 = Workbooks(wb).Worksheets(wsh0).Range("a" & i5).row + 1
            Next i5
          
Application.StatusBar = "Fin d'importation iOMEGA_1"
End If
            

Else
    
  last0 = 2
End If
End If
Next f

Application.StatusBar = "mise a jour terminée pour iOMEGA_1"
End Sub
 
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

J
  • Question
Microsoft 365 Erreur de compilation: sub, fonction ou property attendue
Réponses
4
Affichages
140
dysorthographie
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
81
Latias
L
A
  • Question
XL 2019 Vérifier si une ligne existe dans un autre fichier
Réponses
7
Affichages
465
A-F
A
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
357
M@xu3L
M
  • Question
Microsoft 365 Retrouver les dépendants de cellules nommées
Réponses
6
Affichages
211
crocrocro
C
B
  • Question
Microsoft 365 [RESOLU] Supprimer Ligne rapidement et avec plusieurs conditions
Réponses
5
Affichages
113
BENAM69
B
Z
  • Question
XL 2010 Utilisation variable dans code
Réponses
5
Affichages
298
patricktoulon
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
931
thivame
T
A
  • Question
Microsoft 365 Cpier/coller en VBA
Réponses
7
Affichages
433
A-F
A
A
  • Question
XL 2016 Boucle sur sous répertoire fso.GetFolder SharePoint
Réponses
0
Affichages
274
Aldonanou
A
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…