Transfert de données d'un fichier Excel vers un autre

Le 06/10/2020 à 09:32

Bonjour à tous,

J'ai un programme qui me permets d'incorporer des données via un fichier excel sur un autre fichier excel. Mon problème est que dès que j'arrive sur les séries de la colonne B "VO2N, V2N, Corail BN, Corail HN" j'aimerais que le programme saute les informations de ceux-ci et passe à la ligne suivant sans prendre en compte les données.

De même dès qu'il tombe sur un numéro finissant par "XX" en colonne D.

Merci de votre aide les pro d'excel.

Option Explicit

Dim m_wb_Programme_Hebdo As Workbook
Dim m_wsht_Feuille_Destination As Worksheet
Dim m_rng_Plage_a_Graphiquer As Range
Dim m_lng_Couleur_Graphiquage As Long
Dim m_str_Commentaire As String
Dim m_wsht_Feuille_Programme As Worksheet
Dim m_str_Type_Intervention As String
Dim m_rng_Plage_Commentaire As Range
Dim m_bol_Serie_Valide As Boolean
Dim m_array_S_Plus_1()
Dim m_array_S_Plus_2()
Dim m_array_S_Plus_3()
Dim m_array_S_Plus_4()

Public Sub Insertion_PHP()
    Dim int_Num_Semaine As Integer
    int_Num_Semaine = CInt(Numero_Semaine)
    Call PAUSE_FEUILLE
    Call OUVERTURE_CLASSEUR
    Call LECTURE_SEMAINE_1(int_Num_Semaine)
    Call Fermer_Classeur
    Call GRAPHIQUAGE_SEMAINE_1
    MsgBox "Insertion PHP terminée !"
    Call RETRAIT_PAUSE_FEUILLE
End Sub

Private Function Numero_Semaine() As String
    Numero_Semaine = CStr(DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1)
End Function

Private Sub OUVERTURE_CLASSEUR()
    Dim FileToOpen As Variant
    Call PAUSE_FEUILLE
    FileToOpen = Application.GetOpenFilename("Text Files (*.xls*), *.xls*", , "Veuillez selectionner le programme de visite le plus récent")
    If FileToOpen = False Then
        Call MsgBox("Aucun programe n'a été sélectionné", vbOKOnly + vbCritical, "Erreur")
        End
    End If
    Workbooks.Open (FileToOpen)
    Set m_wb_Programme_Hebdo = ActiveWorkbook
    Call VERIFICATION_CLASSEUR
End Sub

Private Sub VERIFICATION_CLASSEUR()
    Call PAUSE_FEUILLE
    If Not m_wb_Programme_Hebdo.Worksheets(Numero_Semaine).Range("U1").Value = "STF NORMANDIE" Then
        MsgBox "Le classeur ne semble pas être le bon ...", vbOKOnly Or vbCritical, ""
        End
    End If
End Sub

Private Sub Fermer_Classeur()
    m_wb_Programme_Hebdo.Close (False)
End Sub

Private Sub LECTURE_SEMAINE_1(ByVal int_Num_Feuille As Integer)
    Call PAUSE_FEUILLE
    Dim lng_derniere_ligne As Long
    Dim lng_Index As Long
    Dim wsht_Feuille As Worksheet
    Set wsht_Feuille = m_wb_Programme_Hebdo.Worksheets(CStr(int_Num_Feuille))
    lng_derniere_ligne = wsht_Feuille.Range("A" & Rows.Count).End(xlUp).Row
    ReDim m_array_S_Plus_1(lng_derniere_ligne, 10)
    For lng_Index = 0 To lng_derniere_ligne
        With wsht_Feuille
            If .Range("B" & lng_Index + 7) = vbNullString Then GoTo Boucle
                m_array_S_Plus_1(lng_Index, 0) = .Range("B" & lng_Index + 7)            'Serie
            If Numero_Materiel_Valide(.Range("D" & lng_Index + 7)) = True Then      'Numero
                m_array_S_Plus_1(lng_Index, 1) = .Range("D" & lng_Index + 7)
            Else
                GoTo Boucle
            End If
                m_array_S_Plus_1(lng_Index, 2) = .Range("E" & lng_Index + 7)            'Operation
                m_array_S_Plus_1(lng_Index, 3) = .Range("G" & lng_Index + 7)            'Date_Debut
                m_array_S_Plus_1(lng_Index, 4) = .Range("H" & lng_Index + 7)            'Coupon
            If Heure_début_RDV_Valide(.Range("Q" & lng_Index + 7)) = True Then
                m_array_S_Plus_1(lng_Index, 5) = CDate(.Range("Q" & lng_Index + 7))     'Heure_RDV
                m_array_S_Plus_1(lng_Index, 6) = .Range("R" & lng_Index + 7)            'Site_Realisateur
            Else
                GoTo Boucle
            End If
            If IsDate(.Range("V" & lng_Index + 7)) Then
                m_array_S_Plus_1(lng_Index, 7) = CDate(.Range("V" & lng_Index + 7)) 'Date_OA
            Else
                m_array_S_Plus_1(lng_Index, 7) = vbNullString
            End If
                m_array_S_Plus_1(lng_Index, 8) = .Range("Y" & lng_Index + 7)            'Date_Fin
                m_array_S_Plus_1(lng_Index, 9) = CDate(.Range("Z" & lng_Index + 7))     'Heure_Fin
                m_array_S_Plus_1(lng_Index, 10) = .Range("AC" & lng_Index + 7)          'Num_DI
        End With
Boucle:
    Next
End Sub

Private Function Numero_Materiel_Valide(ByVal str_Num_Materiel As String) As Boolean
'Voitures
If Strings.Len(str_Num_Materiel) > 8 Then
Numero_Materiel_Valide = False
Exit Function
End If
'Erreur
If Strings.InStr(str_Num_Materiel, "#REF!") > 0 Then
Numero_Materiel_Valide = False
Exit Function
End If
'Ourson
If Strings.InStr(str_Num_Materiel, "ourson") > 0 Then
Numero_Materiel_Valide = False
Exit Function
End If
'XX
If Strings.InStr(str_Num_Materiel, "xx") > 0 Then
Numero_Materiel_Valide = False
Exit Function
End If

Numero_Materiel_Valide = True
End Function

Private Function Heure_début_RDV_Valide(ByVal str_Heure_début_RDV As String) As Boolean
'Heures non valide
If Strings.InStr(str_Heure_début_RDV, "déjà dur site") > 0 Then
Heure_début_RDV_Valide = False
Exit Function
End If
If Strings.InStr(str_Heure_début_RDV, "déjà sur site") > 0 Then
Heure_début_RDV_Valide = False
Exit Function
End If

Heure_début_RDV_Valide = True
End Function

Private Sub GRAPHIQUAGE_SEMAINE_1()
    Call PAUSE_FEUILLE
    If IsEmpty(m_array_S_Plus_1(0, 0)) Then Exit Sub
    Dim int_Index As Integer
    For int_Index = LBound(m_array_S_Plus_1) To UBound(m_array_S_Plus_1)
        If IsEmpty(m_array_S_Plus_1(int_Index, 0)) Then Exit Sub 'arret lecture données si vide
        Call IDENTIFICATION_FEUILLE_DESTINATION(m_array_S_Plus_1(int_Index, 0))
        If m_bol_Serie_Valide = True Then
            If m_array_S_Plus_1(int_Index, 7) = vbNullString Then ' si date OA est vide
                Call DEFINIR_COMMENTAIRE(m_array_S_Plus_1(int_Index, 2), (m_array_S_Plus_1(int_Index, 10)), _
                m_array_S_Plus_1(int_Index, 6), m_array_S_Plus_1(int_Index, 5))
            Else
                Call DEFINIR_COMMENTAIRE(m_array_S_Plus_1(int_Index, 2), (m_array_S_Plus_1(int_Index, 10)), _
                m_array_S_Plus_1(int_Index, 6), m_array_S_Plus_1(int_Index, 5), m_array_S_Plus_1(int_Index, 7))
            End If
            Call IDENTIFICATION_PLAGE_A_GRAPHIQUER(m_array_S_Plus_1(int_Index, 1), m_array_S_Plus_1(int_Index, 3), m_array_S_Plus_1(int_Index, 8), m_array_S_Plus_1(int_Index, 5), m_array_S_Plus_1(int_Index, 9))
            Call DEFINIR_COULEUR_GRAPHIQUAGE(m_array_S_Plus_1(int_Index, 6))
            Call GRAPHIQUAGE(m_rng_Plage_a_Graphiquer)
        End If
    Next
End Sub

Private Sub IDENTIFICATION_FEUILLE_DESTINATION(ByVal str_Serie As String)
    Call PAUSE_FEUILLE

    m_bol_Serie_Valide = True 'Serie valide par defaut
    Select Case Strings.Trim(str_Serie) 'suppression des espaces avant/apres
    Case "B82500-NA"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("B82500")
    Case "B84500-6C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("B84500")
    Case "B85900-4C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("B85900")
    Case "X72500-3C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("X72500")
    Case "X73500-X735X735"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("X73500")
    Case "X76500-3C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("X76500")
    Case "Z27500-3C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("Z27500_3C")
    Case "Z27500-4C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("Z27500_4C")
    Case "Z26500-5C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("TER_2N_NG")
    Case "Z56600-10C"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("OMNEO")
    Case "VO2N"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("VO2N")
    Case "V2N"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("V2N")
    Case "CORAIL_HN"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("CORAIL_HN")
    Case "CORAIL_BN"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("CORAIL_BN")
    Case "BB63500"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("BB63500")
    Case "BB26000"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("BB26000")
    Case "BB15000NR"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("BB15000_NR")
    Case "BB15000R"
        Set m_wsht_Feuille_Destination = ThisWorkbook.Worksheets("BB15000_R")
    Case Else
        m_bol_Serie_Valide = False 'Serie non valide (ex: Y8000)
    End Select
End Sub

Private Sub IDENTIFICATION_PLAGE_A_GRAPHIQUER(ByVal str_NumeroEngin As String, ByVal dt_DateDebut As Date, ByVal dt_DateFin As Date, ByVal dt_Heure_Debut As Date, ByVal dt_Heure_Fin As Date)
    Call PAUSE_FEUILLE
    Dim int_Ligne As Integer
    Dim int_Colonne_Debut As Integer
    Dim int_Colonne_Fin As Integer
    Dim rng_Cell As Range
    Dim int_Derniere_Ligne As Integer
    Dim rng_Plage_Fin As Range
    Dim int_Colonne_Commentaire As Integer
    int_Derniere_Ligne = Calcul_derniere_ligne(m_wsht_Feuille_Destination.Name)
'Identification de la ligne de l'EM
    For Each rng_Cell In m_wsht_Feuille_Destination.Range("A9:A" & int_Derniere_Ligne)
        If rng_Cell.Value = str_NumeroEngin Then
            int_Ligne = rng_Cell.Row
            Exit For
        End If
        Next rng_Cell
'Identification de la colonne Date de debut
        For Each rng_Cell In m_wsht_Feuille_Destination.Range("V6:ABY6")
            If Format(rng_Cell.Value, "dd/mm/yyyy") = dt_DateDebut Then
'Special X73500 !!
                If m_wsht_Feuille_Destination.Name = "X73500" Then
'Ajustement en fonction de l'heure
                    If dt_Heure_Debut <= "05:00" Then
                        int_Colonne_Debut = rng_Cell.Column - 1
                        int_Colonne_Commentaire = int_Colonne_Debut
                    ElseIf dt_Heure_Debut <= "08:00" Then
'                        int_Colonne_Debut = rng_Cell.Column - 2
                        int_Colonne_Debut = rng_Cell.Column + 0
                        int_Colonne_Commentaire = int_Colonne_Debut
                        Exit For
                    ElseIf dt_Heure_Debut <= "11:30" Then
                        int_Colonne_Debut = rng_Cell.Column
                        int_Colonne_Commentaire = int_Colonne_Debut - 1
                    End If
                End If
'Ajustement en fonction de l'heure
                If dt_Heure_Debut < Format(m_wsht_Feuille_Destination.Cells(7, rng_Cell.Column).Value, "hh:mm") Then
                    int_Colonne_Debut = rng_Cell.Column
                    int_Colonne_Commentaire = int_Colonne_Debut
                    Exit For
                ElseIf dt_Heure_Debut > Format(m_wsht_Feuille_Destination.Cells(7, rng_Cell.Column + 1).Value, "hh:mm") Then
                    int_Colonne_Debut = rng_Cell.Column + 2
                    int_Colonne_Commentaire = int_Colonne_Debut - 1
                    Exit For
                ElseIf dt_Heure_Debut > Format(m_wsht_Feuille_Destination.Cells(7, rng_Cell.Column).Value, "hh:mm") Then
                    int_Colonne_Debut = rng_Cell.Column + 1
                    int_Colonne_Commentaire = int_Colonne_Debut - 1
                    Exit For
                Else
                    int_Colonne_Debut = rng_Cell.Column
                    int_Colonne_Commentaire = int_Colonne_Debut
                End If
            End If
            Next rng_Cell
'Identification de la colonne Date de fin
            Set rng_Plage_Fin = m_wsht_Feuille_Destination.Range(m_wsht_Feuille_Destination.Cells(6, int_Colonne_Debut - 2), m_wsht_Feuille_Destination.Cells(6, 752))
            For Each rng_Cell In rng_Plage_Fin
                If Format(rng_Cell.Value, "dd/mm/yyyy") = dt_DateFin Then
'Special X73500 !!
                    If m_wsht_Feuille_Destination.Name = "X73500" Then
                        If dt_Heure_Fin <= "05:00" Then
                            int_Colonne_Fin = rng_Cell.Column
                            Exit For
                        Else
                        If dt_Heure_Fin >= "11:30" Then
                            int_Colonne_Fin = rng_Cell.Column + 2
                            Exit For
                        Else
                            int_Colonne_Fin = rng_Cell.Column + 1
                            Exit For
                        End If
                        End If
                    End If
'Ajustement en fonction de l'heure
                    If dt_Heure_Fin < Format(m_wsht_Feuille_Destination.Cells(7, rng_Cell.Column + 2).Value, "hh:mm") Then
                        int_Colonne_Fin = rng_Cell.Column
                        Exit For
                    Else
                        int_Colonne_Fin = rng_Cell.Column + 1
                        Exit For
                    End If
                End If
                Next rng_Cell
'Definition de la plage
                If int_Colonne_Debut = int_Colonne_Fin Then
                    Set m_rng_Plage_a_Graphiquer = m_wsht_Feuille_Destination.Cells(int_Ligne, int_Colonne_Debut)
                Else
                    Set m_rng_Plage_a_Graphiquer = m_wsht_Feuille_Destination.Range(m_wsht_Feuille_Destination.Cells(int_Ligne, int_Colonne_Debut), m_wsht_Feuille_Destination.Cells(int_Ligne, int_Colonne_Fin))
                End If
                Set m_rng_Plage_Commentaire = m_wsht_Feuille_Destination.Cells(int_Ligne, int_Colonne_Commentaire)
                Call AJOUTCOMMENTAIRE
            End Sub

Private Sub DEFINIR_COULEUR_GRAPHIQUAGE(ByVal str_Site As String)
    Call PAUSE_FEUILLE
    If str_Site = "SV" Or str_Site = "SVH" Or str_Site = "CA" Or str_Site = "LH" Or str_Site = "GRA" Or str_Site = "BC" Or str_Site = "ACH" Or str_Site = "CBG" Then
        m_lng_Couleur_Graphiquage = ThisWorkbook.Worksheets("ParamètresCouleurs").Range("A5").Interior.Color
        m_str_Type_Intervention = "P"
    Else
        m_lng_Couleur_Graphiquage = ThisWorkbook.Worksheets("ParamètresCouleurs").Range("D5").Interior.Color
        m_str_Type_Intervention = "E"
    End If
End Sub
Private Sub GRAPHIQUAGE(ByVal rng_Plage As Range)
    Call PAUSE_FEUILLE
    Dim int_decal As Integer
    int_decal = 0
'Mise en couleur
    With rng_Plage
        .Interior.Color = m_lng_Couleur_Graphiquage
        .Value = m_str_Type_Intervention
        .Font.Color = m_lng_Couleur_Graphiquage
    End With
    With rng_Plage(rng_Plage.Cells.Count)
        .Offset(0, int_decal).Interior.Pattern = xlNone
        .Offset(0, int_decal).Value = "?"
        .Offset(0, int_decal).Font.Color = vbBlack
    End With
End Sub

Private Sub DEFINIR_COMMENTAIRE(ByVal str_Operation As String, ByVal str_Num_DI As String, ByVal str_Site As String, ByVal dt_Heure_RDV As Date, Optional ByVal dt_Date_OA As Date)
    Call PAUSE_FEUILLE
    m_str_Commentaire = str_Operation & " - " & str_Num_DI & " - " & _
    str_Site & " - " & Format(dt_Heure_RDV, "hh:mm")
End Sub

Private Sub AJOUTCOMMENTAIRE()
    Call PAUSE_FEUILLE
'Vérification si commentaire déjà présent
    If m_rng_Plage_Commentaire.Comment Is Nothing Then
        m_rng_Plage_Commentaire.AddComment
    Else
        m_str_Commentaire = m_rng_Plage_Commentaire.Comment.Shape.AlternativeText + Chr(10) + m_str_Commentaire
    End If

    m_rng_Plage_Commentaire.Comment.Text Text:=m_str_Commentaire
    m_rng_Plage_Commentaire.Comment.Text Text:=Strings.Replace(m_rng_Plage_Commentaire.Comment.Text, "Zone de Texte: ", vbNullString)
End Sub

Private Function Calcul_derniere_ligne(ByVal str_NomFeuille As String, Optional ByVal wb_Classeur As Workbook) As Integer
    Call PAUSE_FEUILLE
    If wb_Classeur Is Nothing Then
        Calcul_derniere_ligne = ThisWorkbook.Worksheets(str_NomFeuille).Range("A" & Rows.Count).End(xlUp).Row
    Else
        Calcul_derniere_ligne = wb_Classeur.Worksheets(str_NomFeuille).Range("A" & Rows.Count).End(xlUp).Row
    End If
End Function

Private Sub PAUSE_FEUILLE()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
End Sub

Private Sub RETRAIT_PAUSE_FEUILLE()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Le 06/10/2020 à 10:14

Bonjour,

Et bien, ça en fait du code.

Je ne l'ai pas lu mais si j'ai bien compris votre besoin, il suffit d'ajouter à l'endroit voulu une condition de type

if cell.value <> "VO2N" then 'idem pour les autres cas

'et

if not cell.value Like "*XX" then

Ensuite pour les instructions, il faut voir ce que vous souhaitez concrètement...

Cdlt,

Rechercher des sujets similaires à "transfert donnees fichier"