Amélioration Macro => ajout collage spécial

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
C

cedric125

XLDnaute Nouveau
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
 
Trier par date Trier par votes
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
Cliquez pour agrandir...
 
Dernière édition:
Vote positif 0 Vote négatif
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.
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
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
 

Pièces jointes

Vote positif 0 Vote négatif
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 ?
 
Vote positif 0 Vote négatif
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....😱
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

N
  • Question Question
Listbox click
Réponses
10
Affichages
289
ChTi160
ChTi160
S
  • Question Question
XL 2021 Listing Album Panini
Réponses
5
Affichages
241
job75
job75
G
  • Question Question
XL 2021 Macro pour changer les titres de fichier d'archive
Réponses
3
Affichages
306
fanch55
fanch55
R
  • Résolu(e)
XL pour MAC La méthode "_default" de l'objet "Range" a échoué
Réponses
5
Affichages
243
Rod59
R
F
  • Question Question
Microsoft 365 Problème mémoire insuffisante
Réponses
5
Affichages
264
TooFatBoy
TooFatBoy
M
  • Question Question
XL 2013 MACRO VBA pour imprimer tous les bulletins d'un établissement scolaire
Réponses
4
Affichages
515
MBEPID
M
G
  • Question Question
XL 2016 Extraire des données d'un pdf et les copier dans excel
2
Réponses
19
Affichages
2 K
kiki29
kiki29
S
  • Résolu(e)
XL 2016 Coller nom classeur sur plage cellules
Réponses
9
Affichages
231
safranien
S
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
685
Gestionnaire_rh
G
C
  • Résolu(e)
Microsoft 365 Amélioration Macro.
Réponses
7
Affichages
625
crazy
C
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
177
CDALE
C
T
  • Résolu(e)
XL 2019 Filtrer certains champs au démarrage avec vba
2
Réponses
15
Affichages
526
telemarrk
T
oguruma
EXCEL :: VBA :: PIVOTTABLE :: PIVOTCACHE :: Nettoyer le cache des TCD
Réponses
0
Affichages
152
oguruma
oguruma
oguruma
EXCEL :: CLASS_LIBRARY_TOOLS_V1.0 - Classes utilitaires - Fichier Log, Gestion de pile d'exécution, isExists, Paramètres, Collection, Dictionnaire
Réponses
0
Affichages
158
oguruma
oguruma
A
  • Question Question
Microsoft 365 Macro pour récupérer des colonnes qui ne sont pas conjointes
Réponses
4
Affichages
386
Anthony_51
A
B
  • Résolu(e)
Microsoft 365 creation d'liste à imprimer
2 3 4
Réponses
51
Affichages
2 K
Banbara
B
K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
264
KRUG WOO
K
oguruma
EXCEL :: Les Tableaux Structurés :: Une classe VBA - V1.05 - Evolutions majeures exports CSV, XML, XML UTF-8, JSON, HTML, PDF, JPG, JPEG, BMP, EXCEL
Réponses
10
Affichages
438
oguruma
oguruma
P
  • Question Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
677
job75
job75
U
  • Question Question
Autres incorporer une macro dans une autre macro
Réponses
5
Affichages
480
Phil69970
Phil69970
Retour