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 83 84 85 86 87 88 89 90
| Option Explicit
Option Private Module
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 : 09/01/2013 (02/01/2013)
' Version 1.2
' Update
' 02/01/2013-1.0 - Version Beta
' 08/01/2013-1.1 - Mise en production
' 09/01/2013-1.2 - Liberé les variables objets
' 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 Sourcesheet As Worksheet
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
'
For Each Sourcesheet In TargetSheet.Worksheet
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("A2").CurrentRegion
Set rngImport = FromSheet.Range("A2").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 '& DebutNomFichier
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 -> Pas de copie
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
End Select
End With
End Select
Next Sourcesheet
Set rngTarget = Nothing: Set rngImport = Nothing: Set LabelTarget = Nothing: Set LabelImport = Nothing
TargetSheet.Cells.EntireColumn.AutoFit
End Function |
Partager