Bonjour chers amis du forum,


J'ai trouver sur le forum un code vraiment intéressant de monsieur Philippe Tulliez. (voir ci-dessous)


Je voudrais adapter ce code a mes besoins. Au lieu d'envoyer les données dans une feuille existante intitulé "Export", je voudrais que la procédure envoie les donnes dans une nouvelle feuille. Ainsi je pourrais faire plusieur fusion dans des onglets différentes dans le même fichier. Également il faudrait que la mise en page (longeur, hauteurs, couleur, police, etc ...) de la zone de titre sois conservé.

Je ne sais pas si je peut tous simple demander de copier les données dans une nouvelle feuille ou je risque d'Avoir des mauvaises surprise ie, les données de la premiere onglet voulu dans un nouveau fichier, les données du second dans un second, etc ...


Pour la mise en page, je n'ai vraimet pas de piste comment faire omis de faire des pastespecial qui selon mois ne serais pas optimal


Est-ce que vous avez des piste de solution afin de répondre a mes besoins ???





Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Private Function ExportTable(FromSheet As Worksheet, TargetSheet As Worksheet, Optional ValueOnly As Boolean = False, Optional ClearSheet As Boolean = False, Optional ShowMsg As Boolean = True) As Long
 ' Copie données contenues ds feuille (FromSheet) vers feuille (TargetSheet)
 ' Contrainte la 1ère cellule doit être A1
 ' Auhor : Philippe Tulliez http://philippe.tulliez.be
 ' Date  : 08/01/2013 (02/01/2013)
 ' Version 1.1
 ' Update
 ' 00/00/0000-x.x
 ' Arguments
 ' FromSheet   - obj WorkSheet (Feuille d'où viennent les données)
 ' TargetSheet - obj WorkSheet (Feuille cible)
 ' [ValueOnly] - Boolean [d:FALSE] Si TRUE copie les valeurs
 ' [ClearSheet]- Boolean [d:=False] si TRUE, Fait un Clear de TargetSheet (Feuille Export)
 ' [ShowMsg]   - Boolean [d:=True] si False n'affiche pas les messages d'incohérence pour les Labels
 ' *** Déclaration ***
 ' ... Variables messages d'erreurs
 Const ver As String = "V 1.0"
 Const ErrTitle As String = "Procédure - ExportTable " & ver
 Dim ErrMsg As String: ErrMsg = "*** Sortie de procédure ***" & vbCrLf & vbCrLf
 '
 Dim c As Integer
 Dim rngTarget As Range, rngImport As Range
 Dim TargetRow As Long, depl As Integer
 Dim LabelTarget As Range, LabelImport As Range
 Dim AddressNew As String
 '
 If FromSheet.Name = TargetSheet.Name Then Exit Function ' Sortie de procédure
 '
 If ClearSheet And TargetSheet.Range("A1").CurrentRegion.count <> 1 Then TargetSheet.Cells.Clear
 '
 ' *** Assignation ***
 Set rngTarget = TargetSheet.Range("A1").CurrentRegion
 Set rngImport = FromSheet.Range("A1").CurrentRegion
 ' ... Ligne titre (Labels)
 Set LabelTarget = rngTarget.Resize(1, rngTarget.Columns.count)
 Set LabelImport = rngImport.Resize(1, rngImport.Columns.count)
 With rngTarget: TargetRow = .Rows.count + Abs(.Rows.count > 1): End With
 With TargetSheet
  AddressNew = .Range(.Cells(TargetRow, 1), .Cells(TargetRow + rngImport.Rows.count - 1, rngImport.Columns.count)).Address
 End With
 ' *** Start ***
 Select Case rngImport.Rows.count
  Case Is > 1
    depl = Abs((TargetRow > 1))
    Set rngImport = rngImport.Offset(depl).Resize(rngImport.Rows.count - depl)
    With rngImport
     Select Case True
        Case rngTarget.count = 1 ' Pas de 1ère ligne (Labels)
          .Copy TargetSheet.Range("A" & TargetRow)
          If ValueOnly Then TargetSheet.Range(AddressNew).Value = TargetSheet.Range(AddressNew).Value
          ExportTable = rngImport.Rows.count
        Case LabelTarget.count = .Resize(1, .Columns.count).count
          '
          ' Vérification si même nombre de colonne et sortie de fonction
          For c = 1 To LabelTarget.Columns.count
           If UCase(LabelTarget.Cells(1, c)) <> UCase(LabelImport.Cells(1, c)) Then
            ' Envoi du message si ShowMsg = TRUE et sortie de procédure
            If ShowMsg Then
             ErrMsg = ErrMsg _
                & vbCrLf & "Etiquette (" & LabelTarget.Cells(1, c) & ") dans feuille [Export]" _
                & vbCrLf & "Pas identique dans [" & FromSheet.Name & "] (" & LabelImport.Cells(1, c) & ")"
             MsgBox ErrMsg, vbInformation + vbOKOnly, ErrTitle
            End If
            ExportTable = rngTarget.Rows.count: Exit Function
           End If
          Next
          '
          .Copy TargetSheet.Range("A" & TargetRow) ' Copie de plage
          ExportTable = rngTarget.Rows.count + rngImport.Rows.count
          If ValueOnly Then TargetSheet.Range(AddressNew).Value = TargetSheet.Range(AddressNew).Value ' Copie Valeur
        Case Else
          ' Nombre de colonnes ds ligne titre pas identique -> Sortie de procédure
          If ShowMsg Then
           ErrMsg = ErrMsg & "Feuille : " & FromSheet.Name & vbCrLf & "Longueur ligne des titres pas identique"
           MsgBox ErrMsg, vbInformation + vbOKOnly, ErrTitle
          End If
          ExportTable = rngTarget.Rows.count: Exit Function
     End Select
    End With
 End Select
 TargetSheet.Cells.EntireColumn.AutoFit
End Function

merci du temps que vous metter a vouloir m'aider


amicalement

jp