Import d'un listing et masquage des colonne de ce listing selon les colonnes visible.

barichon

XLDnaute Junior
Bonsoir,

Je cherche une solution pour importer un listing et faire le masquage des colonnes de ce listing selon les colonnes visible dans la feuille "FR".

Les Colonne Visible de la feuille "FR" de destination sont: "B,H,I,AJ,AK,AS,AW,BO"
Mon import se passe bien mais ca ne colle pas correctement les données =(

Voici mon code de base:

Code:
Sub récup_données()
'récupère à partie de l'extract  .xls
Dim Ouvrir As Variant
répertoire = ThisWorkbook.Path
monfichier = ActiveWindow.Caption
ChDir répertoire

'bases de données à compléter
nouvligticket = Sheets("FR").Range("B" & Rows.Count).End(xlUp).Row + 1

'Import
Valid = MsgBox("Mise à jour des données ? ", vbYesNo)
If Valid = vbYes Then
'ouverture de fichier .csv
 Ouvrir = Application.GetOpenFilename(filefilter:="Fichier donnée Granite(*.xls),*.xls*", Title:="Récupération des Données Ticket")
    If Ouvrir = False Then
        MsgBox "aucun fichier sélectionné", vbOKOnly + vbCritical, "fin de procédure "
        Exit Sub
    End If
    Application.ScreenUpdating = False
    'Vérification si fichier déjà ouvert
    nbfichier = Workbooks.Count
    numfichier = 1
    dejaouvert = 0
    While numfichier <= nbfichier And dejaouvert = 0
        If Ouvrir = répertoire & "\" & Workbooks(numfichier).Name Then dejaouvert = numfichier
        numfichier = numfichier + 1
    Wend
    'ouvert > réactivation fenêtre sinon ouverture
    If dejaouvert <> 0 Then
        MsgBox "fichier déjà ouvert"
        Windows(Workbooks(dejaouvert).Name).Activate
    Else
    Workbooks.Open Filename:=Ouvrir, Format:=5
    End If
    fichiercible = ActiveWindow.Caption
    Columns("A:BZ").EntireColumn.AutoFit
    'complément données sauf si existe
    existe = ""
    derligne = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To derligne
    
    Set celluletrouvee = Workbooks(monfichier).Sheets("FR").Range("B1:B" & nouvligticket).Find(Range("A" & i).Value, lookat:=xlWhole)

    If celluletrouvee Is Nothing Then
        If Not Range("A" & i).Value = "" And Not IsDate(Range("A" & i).Value) Then
           ' MsgBox ("pas trouvé - à ajouter")
           Range("A" & i & ":BR" & i).Copy
           Windows(monfichier).Activate
           Sheets("FR").Activate
           Range("B" & nouvligticket).Select
           ActiveSheet.Paste
           Rows(nouvligticket - 1 & ":" & nouvligticket - 1).Copy
           Rows(nouvligticket & ":" & nouvligticket).PasteSpecial _
           Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
           Application.CutCopyMode = False
           nouvligticket = nouvligticket + 1
           Windows(fichiercible).Activate
        End If
    Else
           ' MsgBox ("existe" - erreur)
           existe = existe & Range("A" & i).Value & " - "
    End If
    Next
    If Not existe = "" Then MsgBox ("Valeurs déjà existantes : " & existe)
    ActiveWorkbook.Close savechanges:=False
  

End If

ActiveWorkbook.RefreshAll

End Sub


Auriez-vous une idée a me donner ?

Merci d'avance,
 

Discussions similaires

Statistiques des forums

Discussions
312 215
Messages
2 086 339
Membres
103 192
dernier inscrit
Corpdacier