Méthode ADO et transfert -fichiers fermes traités- dans autre répertoire

[CAPRI_456]

Bonsoir le Forum

dans la méthode "ADO" via USF ( du dream team : Thierry ,Michel XLD, Michel m)
destinée à copier le contenu de la même feuille de plusieurs classeurs fermés je souhaiterai que les classeurs fermés dont le contenu à été copié !rapidement ! (et oui cela fonctionne admirablement),

le fil : https://www.excel-downloads.com/threads/integration-de-donnees-de-plusieurs-fichiers.34778/

soient transférés dans un répértoire nommé "COLLECTE REALISEE" ceci, afin d'éviter de les recopier une seconde fois..(par erreur lors de la sélection dans le répértoire via le bouton 1 de l'USF)

Voyez vous une possibilité d'ajout dans le code.....de l'USF (bouton "VALIDATION" dont le code figure ci-dessous ? et ainsi permettre d'archiver les fichiers ainsi collectés dans un répertoire "collecte réalisée" ?

Merci pour votre aide

CAPRI_456

Private Sub CmdADOReturnData_Click()
Dim i As Integer
Dim OK As Boolean
Dim ContainerADO_RangeName As Variant
Dim Multi As Boolean
Dim X As Byte


If Me.TxbADO_WorkSheetName = "" Then
MsgBox "Vous devez indiquer un nom de Feuille", vbCritical, T
Exit Sub
End If

If Me.TxbADO_RangeName = "" Then
MsgBox "Vous devez indiquer une Plage", vbCritical, T
Exit Sub
End If

If Me.TxbNumeroChampsNonVide = "" Then
MsgBox "Vous devez indiquer le Numéro du Champs", vbCritical, T
Exit Sub
ElseIf Not IsNumeric(Me.TxbNumeroChampsNonVide) Then
MsgBox "Vous devez indiquer le Numéro du Champs", vbCritical, T
Exit Sub
End If

'Modif pour Multi Range Non Contigues TEST DE RANGE
If InStr(1, Me.TxbADO_RangeName, Chr(59)) > 0 Then
ContainerADO_RangeName = Split(Me.TxbADO_RangeName, Chr(59))
For i = 0 To UBound(ContainerADO_RangeName)
CheckingRangeName CStr(ContainerADO_RangeName(i))
Next
Multi = True
' TxbNumeroChampsNonVide = 1 'Sinon on va planter grave en Multi Range ...
Else
CheckingRangeName Me.TxbADO_RangeName
Multi = False
End If


If Me.OpbValueNotEmpty = True Then
If Multi Then
MsgBox "Option Contrôle de Champs avec Valeurs Non Vides" & vbCrLf & "Non Disponible en Mode Multi Range", vbInformation, T
Me.OpbValueAll = True
Exit Sub
Else
If Me.TxbNumeroChampsNonVide > NumberADOCol Then
MsgBox "Vous ne Pouvez Choisir un Numéro de Champs plus large que la Plage", vbCritical, T
Exit Sub
End If
NumberADOChamps = TxbNumeroChampsNonVide
End If
End If

' With ADO_Collector_Filtered ' ne pas supprimer les datas existants lors des
' .Range("A2:X5000").ClearContents ' collectes successives
' End With
' With ADO_Collector_Global
' .Range("A2:X5000").ClearContents
' End With


With Me.LbxFileSearch
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
If Me.OpbValueNotEmpty = True Then
ADO_Collector_Filtered.Activate
If Not Multi Then
Recup_Zone .Column(0, i), .Column(1, i), Me.TxbADO_WorkSheetName, Me.TxbADO_RangeName
End If
Else
ADO_Collector_Global.Activate
If Not Multi Then
ADOReader .Column(0, i), .Column(1, i), Me.TxbADO_WorkSheetName, Me.TxbADO_RangeName
Else
For X = 0 To UBound(ContainerADO_RangeName)
ADOReader .Column(0, i), .Column(1, i), Me.TxbADO_WorkSheetName, CStr(ContainerADO_RangeName(X))
Next
End If
End If
OK = True
End If
Next
End With

If OK = False Then
MsgBox "Pour que cette option fonctionne vous devez sélectionner dans Fichier en 2)", vbCritical, T
Exit Sub
End If

If TabNotADOIndexWSName > 0 Or TabNotADOIndexWBOpen > 0 Then
With USF2
If TabNotADOIndexWSName > 0 Then
With .ListBox1
.Column() = TabNotADOCompliantWSName
End With
.LblSheetName = TabNotADOCompliantWSName(1, 0)
End If
If TabNotADOIndexWBOpen > 0 Then
With .ListBox2
.Column() = TabNotADOCompliantWBOpen
End With
End If
.Caption = "Program Warning !!!"
.Show
End With
End If

End Sub