Amélioration Macro => ajout collage spécial

cedric125 · 16 Octobre 2011

Bonjour à tous

j'ai besoin pour mon travail d'adapter mon code suivant de manière a faire un collage spécial "valeur" à la place du collage normal puisque les dates du fichier sources ne passent pas j'ai essayé plusieurs manip sans succès

Merci d'avance pour votre aide

Sub Copie(CL2 As Workbook)
Dim LaFeuille As Worksheet, FL1 As Worksheet, derlig As Long
Set FL1 = ThisWorkbook.Worksheets("feuil1") 'feuille où les données sont collées
For Each LaFeuille In CL2.Worksheets 'parcours du classeur à copier
'On vérifie que la feuille n'est pas vide
If Not (LaFeuille.UsedRange.Address = "$A$1" And Range("A1") = "") Then
derlig = FL1.Range("A" & Rows.Count).End(xlUp).Row + 1 'première ligne vide
On Error Resume Next
LaFeuille.UsedRange.Copy FL1.Cells.Cells(derlig, 1)

DoEvents
If Err <> 0 Then
msg = msg & "Classeur " & NomFich & " feuille " & LaFeuile.Name & vbCrLf
On Error GoTo 0
End If
End If
Next
End Sub

nyko283 · 16 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour Cédric,

Voici c que dit l'aide Excel a propos du collage spécial "PasteSpecial"

PasteSpecial, méthode
Voir aussiS'applique àExempleDétailsMéthode PasteSpecial telle qu'elle s'applique à l'objet Range.

Cette méthode colle un objet Range provenant du Presse-papiers dans la plage spécifiée.

expression.PasteSpecial(Paste, Operation, SkipBlanks, Transpose)
expression Obligatoire. Expression qui renvoie un objet Range.

Paste Argument de type XlPasteType facultatif. Partie de la plage à copier.

XlPasteType peut être l'une de ces constantes XlPasteType.
xlPasteAll par défaut
xlPasteAllExceptBorders
xlPasteColumnWidths
xlPasteComments
xlPasteFormats
xlPasteFormulas
xlPasteFormulasAndNumberFormats
xlPasteValidation
xlPasteValues
xlPasteValuesAndNumberFormats

Operation Argument de type XlPasteSpecialOperation facultatif. Opération de collage.

XlPasteSpecialOperation peut être l'une de ces constantes XlPasteSpecialOperation.
xlPasteSpecialOperationAdd
xlPasteSpecialOperationDivide
xlPasteSpecialOperationMultiply
xlPasteSpecialOperationNone par défaut
xlPasteSpecialOperationSubtract

SkipBlanks Argument de type Variant facultatif. Affectez-lui la valeur True pour que les cellules vides de la plage provenant du Presse-papiers ne soient pas collées dans la plage de destination. La valeur par défaut est False.

Transpose Argument de type Variant facultatif. Affectez-lui la valeur True pour transposer les lignes et les colonnes lorsque la plage est collée. La valeur par défaut est False.

Exemple
Telle qu'elle s'applique à l'objet Range.

Cet exemple montre comment remplacer les données des cellules D1 à D5 de la feuille « Sheet1 » par la somme de leur contenu et des cellules C1 à C5 de la feuille « Sheet1 ».

With Worksheets("Sheet1")
.Range("C1:C5").Copy
.Range("D1: D5").PasteSpecial _
Operation:=xlPasteSpecialOperationAdd
End With

nyko283 · 16 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Sinon j'ai rencontré le poblème y a pas longtemps, j'avais un fichier excel, généré par un tiers programme par un export, mon problème était qu'en fait toutes mes dates étaient en format texte donc pour pouvoir les utiliser je devis au moyen d'un boucle sur le fichier transformer ce texte en date.
grace à :

VB:

For i = 1 To .Range("A65536").End(xlUp).Row
        
        If .Cells(i, 9).Value <> "" Then .Cells(i, 9).Value = CDate(.Cells(i, 9).Value)
        If .Cells(i, 10).Value <> "" Then .Cells(i, 10).Value = CDate(.Cells(i, 10).Value)
    Next i

mes dates se trouvaient dans les colonnes I et J.

cedric125 · 16 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour Nyko
merci pour ton aide j'ai modidié mon code de la facon suivante

LaFeuille.UsedRange.Copy FL1.Cells.Cells(derlig, 1).Select
Selection.PasteSpecial Paste:=xlValues

mais le collage speciale ne fonctione pas ,la date colonne G de mon fichier source est issue de la fonction mois décalé c'est pour ca que la date ne se copie pas avec le collage normal

voir fichier source
Lien CJoint.com 0Jot7pxe5rK

voici le code comlet(fusion de plusieurs fichiers excel en 1 seul)

Sub Appel()
Dim Chemin As String
Application.ScreenUpdating = False
Chemin = "D:\Documents and Settings\croussel\Bureau\Macro\"
Ouvrir Chemin
Application.ScreenUpdating = True
If msg <> "" Then _
MsgBox "Pour des raisons de protection ou autres, n'ont pu être copiées " & vbCrLf & msg
End Sub

Sub Ouvrir(Chemin As String)
Dim NomFich As String
Dim CL2 As Workbook 'fichier copié
Application.DisplayAlerts = False 'Evite les messages d'Excel
'Evite l'exécution éventuelle de macros liées aux fichiers ouverts
Application.EnableEvents = False
NomFich = Dir(Chemin & "*.xls")
If NomFich = "" Then
MsgBox "Aucun fichier trouvé dans " & Chemin
Exit Sub
End If
Do While NomFich <> ""
Set CL2 = Workbooks.Open(Chemin & NomFich)
DoEvents
Copie CL2
CL2.Close False
DoEvents
ThisWorkbook.Save 'enregistrement du classeur après chaque copie
DoEvents
NomFich = Dir
Loop
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

Sub Copie(CL2 As Workbook)
Dim LaFeuille As Worksheet, FL1 As Worksheet, derlig As Long
Set FL1 = ThisWorkbook.Worksheets("feuil1") 'feuille où les données sont collées
For Each LaFeuille In CL2.Worksheets 'parcours du classeur à copier
'On vérifie que la feuille n'est pas vide
If Not (LaFeuille.UsedRange.Address = "$A$1" And Range("A1") = "") Then
derlig = FL1.Range("A" & Rows.Count).End(xlUp).Row + 1 'première ligne vide
On Error Resume Next
LaFeuille.UsedRange.Copy FL1.Cells.Cells(derlig, 1).Select
Selection.PasteSpecial Paste:=xlValues

DoEvents
If Err <> 0 Then
msg = msg & "Classeur " & NomFich & " feuille " & LaFeuile.Name & vbCrLf
On Error GoTo 0
End If
End If
Next
End Sub

Compte Supprimé 979 · 16 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour le fil

Punaise Cedric125 ...
je pense que tu te fous vraiment de la g*le des gens sur ce forum 😡

Encore un post supplémentaire sur le même sujet
https://www.excel-downloads.com/thr...-feuille-les-donnees-dautres-feuilles.162782/
https://www.excel-downloads.com/threads/fusion-de-donnees-de-plusieurs-classeurs.125118/
https://www.excel-downloads.com/threads/faire-une-compilation-de-donnees-a-laide-dun-macro.146001/
https://www.excel-downloads.com/threads/macro-compilation-fichiers.145227/
https://www.excel-downloads.com/thr...es-donnees-les-unes-a-cote-des-autres.122286/

Y'a pas à dire ... tu seras élu d'or 2011

PascalXLD · 16 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour

Suite au dernier post de Bruno j'ai supprimé tous tes posts que tu avais dispersé partout

Merci d'ouvrir un nouveau sujet la prochaine fois comme tu viens de le faire ici

Bonne soirée

cedric125 · 16 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour

dsl je suis nouveau sur le site et je recherchais juste un coup de main pour mon pb maintenant j'ai compris le fonctionement par sujet

cdt

nyko283 · 17 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour Cédric, le forum,

petite astuce en passant, lorsque le code que tu essaie ne fonctionne pas, evite les "On Error Resume Next" ou les "Application.DisplayAlerts=False" ainsi que "Application.ScreenUpdating=False" car tu bloque tous les moyens de savoir ou ton code n'agit pas comme tu le souhaite ou alors s'il y a une erreur comme dans ton code...

En fait en allant chercher les données a copier lorsque tu revient sur ton fichier de base ( là où tu veut coller), il faut d'abord activer le classeur, puis sélectionné la feuille et enfin sélectionner la cellule.

Donc dans ton code remplace :

VB:

LaFeuille.UsedRange.Copy FL1.Cells.Cells(derlig, 1).Select
Selection.PasteSpecial Paste:=xlValues

par :

VB:

LaFeuille.UsedRange.Copy
ThisWorkbook.Activate
FL1.Select
FL1.Cells(derlig, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues

Guest · 17 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour à tous,

@Pascal🙂: un autre post, même question, de Cedric : https://www.excel-downloads.com/threads/copie-speciale-valeur-cellules-par-vba.145937/

A+ à tous

kjin · 17 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour,
Je ne rencontre aucune difficulté particulière si les colonnes "dates" sont bien au format date.
Note qu'un exemple du fichier de destination eut été bienvenu

Code:

Sub Appel()
Dim pRep As String
Application.ScreenUpdating = False
pRep = "D:\Documents and Settings\croussel\Bureau\Macro\"
Ouvrir pRep
Application.ScreenUpdating = True
End Sub

Sub Ouvrir(pRep$)
Dim pFich As String, wb As Workbook
pFich = Dir(pRep & "*.xls")
If pFich = "" Then
    MsgBox "Aucun fichier trouvé dans " & pRep
    Exit Sub
End If
Do While pFich <> "" And pFich <> ThisWorkbook.Name
    Application.EnableEvents = False
    Set wb = Workbooks.Open(pRep & pFich)
    Copie wb
    wb.Close False
    Application.EnableEvents = True
    ThisWorkbook.Save
    pFich = Dir
Loop

End Sub

Sub Copie(wb As Workbook)
Dim ws As Worksheet, dest As Range, source As Range
With ThisWorkbook.Worksheets("feuil1")
    For Each ws In wb.Worksheets
        Set dest = .Range("A65000").End(xlUp).Offset(1, 0)
        With ws
            If .Range("A22") <> "" Then
                tablo = .Range("A22:J" & .Range("A65000").End(xlUp).Row).Value
            End If
        End With
        dest.Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
        dest.Offset(0, 10).Resize(UBound(tablo, 1), 1) = ws.Name
    Next
End With
Erase tablo
End Sub

A+
kjin

cedric125 · 17 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour Nyko et Kjin pour vos 2 solutions qui fonctionnent très bien ca va bien me dépaner pour mon boulot et surtout me faire gagner du temps ,par contre j'ai 2 petites questions additionnelles
la première sur chaque feuille source il y a en B2 le code du produit et je souhaiterais le faire apparaitre en face de chaque enregistrement en plus du non de la feuille(comme sur la macro de Kjin) puisque parfois il a des informations plus complètes en B2

Lien CJoint.com 0Jot7pxe5rK

la deuxième choses j'ai 30 fichiers avec une dizaine de feuilles je risque de dépasser les 65560 lignes donc ça va récrasser les premières lignes ? est-il possible une fois les 65560 lignes attentes de créer un autre feuille pour stocker les données ainsi de suite ?

nyko283 · 19 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Bonjour Cédric

Je suis partit du code de Kjin, et ai apporté quelques modifications pour répondre à tes demandes.

VB:

Sub Copie(wb As Workbook)
Dim ws As Worksheet, dest As Range, source As Range, maRef As String, maligne As Integer
Dim tablo()
    For Each ws In wb.Worksheets
        Set dest = ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count).Range("A65536").End(xlUp).Offset(1, 0)
        With ws
            maRef = .Range("B2").Value
            If .Range("A22") <> "" Then
                If (65536 - dest.Row + 1) >= (.Range("A22").End(xlDown).Row - 22) Then
                ' cas si il reste suffisament de lignes dans le fichier destination
                ReDim tablo(1 To 10, 1 To .Range("A22").End(xlDown).Row)
                    tablo = .Range("A22:J" & .Range("A22").End(xlDown).Row).Value
                    dest.Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
                    dest.Offset(0, 10).Resize(UBound(tablo, 1), 1) = ws.Name & " / " & maRef
                Else
                ' cas ou il faille créer une nouvelle feuille
                
                    'copie premiere partie des données jusqu'a la derniere lignes
                    ReDim tablo(1 To 10, 1 To (65536 - dest.Row + 22))
                    tablo = .Range("A22:J" & (65536 - dest.Row + 22)).Value
                    maligne = (65536 - dest.Row + 22) + 1
                    dest.Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
                    dest.Offset(0, 10).Resize(UBound(tablo, 1), 1) = ws.Name & " / " & maRef
                    
                    ' ajoute une feuille à la fin du classeur
                    ThisWorkbook.Sheets.Add.Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count - 1).Range("A1:J1").Copy Destination:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Range("A1")
                    
                    ' copie le reste de la feuille
                    ReDim tablo(1 To 10, 1 To .Range("A22").End(xlDown).Row - maligne)
                      tablo = .Range("A" & maligne & ":J" & .Range("A22").End(xlDown).Row).Value
                    Set dest = ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count).Range("A2")
                    dest.Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
                    dest.Offset(0, 10).Resize(UBound(tablo, 1), 1) = ws.Name & " / " & maRef
                
                End If
            End If
        End With
    Next

Erase tablo
End Sub

Cf Kjin : Désolé si j'ai un peu malmener ton code source....😱

cedric125 · 19 Octobre 2011

Re : Amélioration Macro => ajout collage spécial

Merci beaucoup Nyko283 ca marche du tonnerre

Amélioration Macro => ajout collage spécial

cedric125

XLDnaute Nouveau

nyko283

XLDnaute Occasionnel

nyko283

XLDnaute Occasionnel

cedric125

XLDnaute Nouveau

Compte Supprimé 979

Guest

PascalXLD

XLDnaute Barbatruc

cedric125

XLDnaute Nouveau

nyko283

XLDnaute Occasionnel

Guest

Guest

kjin

XLDnaute Barbatruc

Pièces jointes

cedric125

XLDnaute Nouveau

nyko283

XLDnaute Occasionnel

Pièces jointes

cedric125

XLDnaute Nouveau

Discussions similaires

Amélioration Macro => ajout collage spécial

XLDnaute Nouveau

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Nouveau

Compte Supprimé 979

Guest

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Occasionnel

Guest

Guest

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Occasionnel

Pièces jointes

XLDnaute Nouveau

Discussions similaires

Privacy & Transparency

Privacy & Transparency