XL 2013 (Résolu par JOB) importation des données sauf les lignes avec cellules en GRAS

ibni · 26 Octobre 2016

Bonjour à tous,
Je me permets de solliciter votre aide après avoir parcouru en long et en large mon ami Google ainsi que ce forum en vain.
En fait, je suis absolument nul et j'aimerais savoir est ce que c'est possible d'appliquer le code ci-dessous sur mon fichier joint pour importer toutes les données du fichier Matos vers Recap sans importer les lignes dont une cellule est en GRAS ( c'est à dire les lignes 8, 39,65,99,117,270,307,338,342,343,350,366,372,380,424,460,477,484,504,536,558,574,598,602)

VB:

Private Sub CommandButton1_Click()
Dim t, nlig&, d As Object, i&, rest(), j&
Application.ScreenUpdating = False
With Workbooks.Open(ThisWorkbook.Path & "\Paie-Mens.xlsx").Sheets("Feuil1")
  t = .Range("A5:AC" & .Range("F" & .Rows.Count).End(xlUp).Row + 2)
  nlig = UBound(t)
  .Parent.Close False
End With
'---restitution du 1er tableau---
[E:E].Copy [AE1] 'sauvegarde la colonne E (matricules) en colonne auxiliaire AE
Range("A3:AC" & Rows.Count).ClearContents 'RAZ
[A3].Resize(nlig, 29) = t
'---liste des noms du 1er tableau---
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  If t(i, 5) <> "" Then d(t(i, 5)) = i 'repère la ligne
Next i
'---création du 2ème tableau (rest)---
t = Range("AD3:AE" & Range("AE" & Rows.Count).End(xlUp).Row + 1)
ReDim rest(1 To nlig, 1 To 1)
For i = 1 To UBound(t)
  If t(i, 2) <> "" And d.Exists(t(i, 2)) Then rest(d(t(i, 2)), 1) = t(i, 1)
Next i
'---restitution du 2ème tableau (rest)---
[[URL='http://ae:af].delete/']AE:AF].Delete[/URL] 'à l'origine il y avait des formules en colonne AF
Range("AD3:AD" & Rows.Count).ClearContents 'RAZ
[AD3].Resize(nlig) = rest
End Sub

Merci pour votre aide

ibni · 27 Octobre 2016

ah oui je comprends donc je dois créer une colonne de référence si non c'est impossible ??

job75 · 28 Octobre 2016

Bonjour ibni, le forum,

Dans ce fichier (4) j'utilise comme références sans doublon les concaténations de toutes les cellules de A à K de chaque ligne :

Code:

Function Gras(c As Range) As Boolean
Gras = c.Characters(1, 1).Font.Bold
End Function

Sub Importer()
Dim t#, F As Worksheet, d As Object, derlig1&, tablo, i&, x$, j%, derlig&, code, coderest()
t = Timer
Set F = Feuil1 'CodeName de la feuille de destination
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'---liste sans doublon des concaténations de A à K---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
derlig1 = F.Cells(F.Rows.Count, 1).End(xlUp).Row
If derlig1 > 7 Then
    tablo = F.Range("A8:K" & derlig1) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 11 'A à K
          x = x & "#" & tablo(i, j)
        Next j
        If x <> "" Then d(x) = i 'repérage de la ligne
    Next i
End If
F.Range("A8:K" & F.Rows.Count).Delete xlUp 'RAZ
'---copie du tableau source---
With Workbooks.Open(ThisWorkbook.Path & "\MATOS.xlsx").Sheets(1) 'feuille source
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    derlig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If derlig > 7 Then .Range("A8:K" & derlig).Copy F.[A8]
    .Parent.Close False
    If derlig < 8 Then derlig = 7: GoTo 1
End With
'---suppression des lignes en gras---
F.[L:L].Insert 'insertion d'une colonne auxiliaire devant la colonne L
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/Gras(RC1)" 'utilise la fonction
    .Value = .Value 'supprime les formules
    F.Range("A8", .Cells).Sort .Cells, xlDescending, Header:=xlNo 'tri pour accélérer, les "1" sont en bas
    derlig = derlig - Application.Count(.Cells)
    On Error Resume Next 's'il n'y a pas de police "gras"
    Intersect(.SpecialCells(xlCellTypeConstants, 1).EntireRow, F.[A:L]).Delete xlUp
End With
F.[L:L].Delete 'suppression de la colonne auxiliaire
'---repositionnement des codes colonne L---
If derlig1 > 7 And derlig > 7 Then
    tablo = F.Range("A8:K" & derlig)
    code = F.Range("L8:M" & derlig1) 'au moins 2 éléments
    ReDim coderest(1 To derlig, 1 To 1)
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 11 'A à K
          x = x & "#" & tablo(i, j)
        Next j
        If d.exists(x) Then coderest(i, 1) = code(d(x), 1)
    Next i
    F.Range("L8:L" & derlig) = coderest
End If
'---finale---
F.Range("B8:L" & derlig).Borders.Weight = xlThin 'bordures
1 F.Rows(derlig + 1 & ":" & F.Rows.Count).Delete 'RAZ en dessous du tableau
With F.UsedRange: End With 'actualise la barre de défilement verticale
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s"), , "Importation"
End Sub

Chaque code en colonne L est restitué s'il n'y a eu aucune modification de sa ligne.

A+

ibni · 28 Octobre 2016

Bonjour Job,
merci beaucoup pour ce travail je ne sais pas vraiment si ça vous a pris du temps pour le réaliser pour quelqu'un qui ne connait rien en VBA c'est enorme..
est ce qu'on pourrait exclure les colonnes I, J, K vu que les montants de ces colonnes changent régulièrement

Merci d'avance

job75 · 28 Octobre 2016

Re,

ibni à dit:
est ce qu'on pourrait exclure les colonnes I, J, K vu que les montants de ces colonnes changent régulièrement

Il suffit alors de concaténer uniquement les colonnes A à H, voyez le fichier (5).

A+

ibni · 28 Octobre 2016

RE,
Merci beaucoup Job c'est le résultat dont j'ai rêvé il y'a presque deux semaines 🙂
je vais essayer de l'appliquer sur mon fichier d'origine et je vus tiens au courant par la suite

à bientôt

Amicalement
Ibni

job75 · 28 Octobre 2016

Re,

Un détail, il faut écrire par sécurité :

Code:

    code = F.Range("L8:M" & derlig1) 'au moins 2 éléments

J'ai corrigé les fichiers (4) et (5).

A+

job75 · 28 Octobre 2016

Re,

On peut même restituer les couleurs en colonne L s'il y en a :

Code:

Function Gras(c As Range) As Boolean
Gras = c.Characters(1, 1).Font.Bold
End Function

Sub Importer()
Dim t#, F As Worksheet, d As Object, derlig1&, tablo, i&, x$, j&, derlig&
Dim P As Range, code, coderest(), flag As Boolean
t = Timer
Set F = Feuil1 'CodeName de la feuille de destination
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'---liste sans doublon des concaténations de A à H---
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
derlig1 = F.Cells(F.Rows.Count, 1).End(xlUp).Row
If derlig1 > 7 Then
    tablo = F.Range("A8:H" & derlig1) 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 8 'A à H
            x = x & "#" & tablo(i, j)
        Next j
        If x <> "" Then d(x) = i 'repérage de la ligne
    Next i
End If
F.Range("A8:K" & F.Rows.Count).Delete xlUp 'RAZ
'---copie du tableau source---
With Workbooks.Open(ThisWorkbook.Path & "\MATOS.xlsx").Sheets(1) 'feuille source
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    derlig = .Cells(.Rows.Count, 1).End(xlUp).Row
    If derlig > 7 Then .Range("A8:K" & derlig).Copy F.[A8]
    .Parent.Close False
    If derlig < 8 Then derlig = 7: GoTo 1
End With
'---suppression des lignes en gras---
F.[L:L].Insert 'insertion d'une colonne auxiliaire devant la colonne L
With F.Range("L8:L" & derlig)
    .FormulaR1C1 = "=1/Gras(RC1)" 'utilise la fonction
    .Value = .Value 'supprime les formules
    F.Range("A8", .Cells).Sort .Cells, xlDescending, Header:=xlNo 'tri pour accélérer, les "1" sont en bas
    derlig = derlig - Application.Count(.Cells)
    On Error Resume Next 's'il n'y a pas de police "gras"
    Intersect(.SpecialCells(xlCellTypeConstants, 1).EntireRow, F.[A:L]).Delete xlUp
End With
F.[L:L].Delete 'suppression de la colonne auxiliaire
'---repositionnement des codes colonne L---
If derlig1 > 7 And derlig > 7 Then
    tablo = F.Range("A8:H" & derlig)
    Set P = F.Range("L8:L" & derlig1)
    code = P.Resize(, 2) 'au moins 2 éléments
    ReDim coderest(1 To derlig, 1 To 2)
    For i = 1 To UBound(tablo)
        x = ""
        For j = 1 To 8 'A à H
            x = x & "#" & tablo(i, j)
        Next j
        If d.exists(x) Then
            j = d(x)
            coderest(i, 1) = code(j, 1)
            If P(j).Interior.ColorIndex <> xlNone Then coderest(i, 2) = P(j).Interior.Color: flag = True
        End If
    Next i
    F.Range("L8:L" & derlig) = coderest
    '---restitution des couleurs colonne L---
    If flag Then
        P.Interior.ColorIndex = xlNone 'RAZ des couleurs
        For i = 1 To UBound(tablo)
            If coderest(i, 2) <> "" Then P(i).Interior.Color = coderest(i, 2)
        Next i
    End If
End If
'---finale---
F.Range("B8:L" & derlig).Borders.Weight = xlThin 'bordures
1 F.Rows(derlig + 1 & ":" & F.Rows.Count).Delete 'RAZ en dessous du tableau
With F.UsedRange: End With 'actualise la barre de défilement verticale
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \s"), , "Importation"
End Sub

Fichier (5 bis).

ibni · 28 Octobre 2016

D'accord je le ferai à jour tout de suite sur mon fichier d'origine et je vais l'essayer et je vous tiendrai au courant
Merci encore une autre fois Job

job75 · 29 Octobre 2016

Bonjour ibni, le forum,

J'ai recopié les lignes 8:606 du fichier MATOS sur 607:11987.

Bien sûr il y a ainsi des doublons mais c'est juste pour tester.

La macro du fichier (5 bis) s'exécute chez moi (Win 10 - Excel 2013) en un peu plus de 6 secondes, c'est très acceptable.

Je note que si toutes les cellules en colonne L sont colorées ça n'augmente guère la durée d'exécution.

Bonne journée.

ibni · 29 Octobre 2016

Bonjour Job,
dans le classeur d'origine (MATOS) les colonnes comme D,E,F,G contiennent des couleurs, est ce qu'il y'a possibilité de changer le code que vous m'avez fourni pour ne pas importer ces couleurs dans le fichier RECAP pour que toutes les cellules dans le fichier de destination soient sans couleur remplissage??

autre chose est ce que c'est possible d'importer les chiffres en valeurs et non pas avec formules ??

Merci d'avance

job75 · 29 Octobre 2016

Re,

Fichier (6) avec ce code modifié :

Code:

    If derlig > 7 Then
        .Range("A8:K" & derlig).Interior.ColorIndex = xlNone 'aucune couleur de fond
        .Range("A8:K" & derlig).Font.ColorIndex = xlAutomatic 'police sans couleur
        .Range("A8:K" & derlig).ClearComments 'supprime les commentaires
        .Range("J8:K" & derlig) = .Range("J8:K" & derlig).Value 'supprime les formules
        .Range("A8:K" & derlig).Copy F.[A8] 'copie tout le reste
    End If

Edit : voir post #28.

A+

ibni · 30 Octobre 2016

Bonsoir Job,
la dernière modification exclut la couleur de fond après importation, par contre les chiffres qui étaient écrits en rouge ont gardé la même couleur après importation

job75 · 30 Octobre 2016

Bonjour ibni, le forum,

ibni à dit:
pour que toutes les cellules dans le fichier de destination soient sans couleur remplissage??

Les couleurs de police peuvent être utiles, néanmoins je vais compléter mon post #26 en supprimant aussi les commentaires.

Bonne journée.

ibni · 30 Octobre 2016

Bonjour Job,
les couleurs de police ne sont pas utile dans mon cas.
je n'ai pas fait attention au commentaires que j'aimerais aussi les enlever

Merci d'avance

job75 · 30 Octobre 2016

Re,

Bah lisez mieux mon post #28 ainsi que le code du post #26...

XL 2013 (Résolu par JOB) importation des données sauf les lignes avec cellules en GRAS

ibni

XLDnaute Nouveau

Pièces jointes

ibni

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

ibni

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

ibni

XLDnaute Nouveau

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

ibni

XLDnaute Nouveau

job75

XLDnaute Barbatruc

ibni

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

ibni

XLDnaute Nouveau

job75

XLDnaute Barbatruc

ibni

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Discussions similaires

XL 2013 (Résolu par JOB) importation des données sauf les lignes avec cellules en GRAS

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency