Recuperation de date qui ne fonctionne pas bien

[magic-dd]

bonjour
suite à un fichier .bas trouve sur le site de fred sigonneau, j'ai adapte le code à mon projet mais un proble subsiste.

suite a la mise en place d'une macro pour recuperer des donnees dans
un classeur fermé, tout fonctionne pour le texte mais pour les dates
recuperees ca bug, cela ne m'ecrit pas la date telle qu'elle est dans
mon classeur fermé

voici le fichier joint

Cijoint.fr - Service gratuit de dépôt de fichiers
et le code
voici le code que j'ai pour recuperer mes donnees

Sub LoopThruFiles()
Application.EnableEvents = False

Dim place As String
Dim FilesArray() As String, FileCounter As Integer
Dim FName As String, LoopCounter As Integer

FName = Dir(ThisWorkbook.Path & "\LISTE\*.xls")
Do While Len(FName) > 0
FileCounter = FileCounter + 1
ReDim Preserve FilesArray(1 To FileCounter)
FilesArray(FileCounter) = FName
FName = Dir()
Loop
If FileCounter > 0 Then
Application.ScreenUpdating = False
For LoopCounter = 1 To FileCounter

x = LoopCounter
'calcul de la plage de destination
place = Range(Cells((((x - 1) * 99) + 2), 1), Cells(((x *
99)), 7)).Address

'METTRE LA LETTRE DU DISQUE DUR CONCERNE C,D, E,ETC...

GetValues "E:", FilesArray(LoopCounter), "Blad1",
"a1:G100", place
Next
Application.ScreenUpdating = True
End If

Columns("A:G").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
Application.EnableEvents = True
End Sub

Sub GetValues(fPath As String, FName As String, sName, _
cellRange As String, place As String)

'recopie une plage des valeurs externes dans une plage de
'la feuille active sous forme d'une formule matricielle
With ActiveSheet.Range(place)
.FormulaArray = "='" & ThisWorkbook.Path & "\LISTE" & "\[" &
FName & "]" & sName & "'!" & cellRange

.Value = .Value
Range(place).Select
Selection.Replace What:="0", Replacement:="", LookAt:=xlPart,
_
SearchOrder:=xlByRows, MatchCase:=False,
SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select

End With

End Sub

 

[Bebere]

Re : Recuperation de date qui ne fonctionne pas bien

bonsoir magicdd
tout va bien,sauf ce qui suit
enlève les 0 des dates aussi

' Selection.Replace What:="0", Replacement:="", LookAt:=xlPart, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
je te met un autre code,à adapter
je pense de la même origine que le tien

Attribute VB_Name = "LireEcrireFichierFerme"

'Pour lire et écrire dans un classeur fermé en utilisant ADO,
'la bibliothèque
'Microsoft ActiveX Data Objects 2.x Library
'doit être cochée dans Outils\Références du VBAProject.

' 1 - Obtenir des données d'un classeur fermé

Sub LitDatas()
Dim Fich$, Arr

Fich = "d:\TestAdo.xls" 'à adapter

'récup des données à partir de l'adresse d'une plage de cellules
GetExternalData Fich, "Feuil1", "A1:G20", False, Arr

'récup des données à partir du nom d'une plage de cellules ()
' GetExternalData Fich, "", "plagenommée", False, Arr

With ThisWorkbook.Sheets("Feuil1")
.Range("A1", .Cells(UBound(Arr, 1), UBound(Arr, 2))).Value = Arr
End With

End Sub

'renvoie les valeurs d'une plage de cellules contigües (srcRange)
'd'une feuille (srcSheet) d'un fichier (srcFile) fermé
'dans un tableau (outArr)
'le paramètre TTL indique si la plage a ou non une ligne d'entêtes
Sub GetExternalData(srcFile As String, _
srcSheet As String, _
srcRange As String, _
TTL As Boolean, _
outArr As Variant)
'd'après Héctor Miguel, mpep
Dim myConn As ADODB.Connection, myCmd As ADODB.Command
Dim HDR As String, myRS As ADODB.Recordset, RS_n As Integer, RS_f As Integer
Dim Arr

Set myConn = New ADODB.Connection
If TTL = True Then HDR = "Yes" Else HDR = "No"
myConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 8.0;" & _
"HDR=" & HDR & ";IMEX=1;"""
Set myCmd = New ADODB.Command
myCmd.ActiveConnection = myConn
If srcSheet = "" _
Then myCmd.CommandText = "SELECT * from `" & srcRange & "`" _
Else myCmd.CommandText = "SELECT * from `" & srcSheet & "$" & srcRange & "`"
Set myRS = New ADODB.Recordset
myRS.Open myCmd, , adOpenKeyset, adLockOptimistic
ReDim Arr(1 To myRS.RecordCount, 1 To myRS.Fields.Count)
myRS.MoveFirst
Do While Not myRS.EOF
For RS_n = 1 To myRS.RecordCount 'lignes
For RS_f = 0 To myRS.Fields.Count - 1 'colonnes
Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value
Next
myRS.MoveNext
Next
Loop
myConn.Close
Set myRS = Nothing
Set myCmd = Nothing
Set myConn = Nothing

outArr = Arr

End Sub

' 2 - Ecrire dans un classeur fermé

Sub EcritDatas()
Dim Fich$, cell As Range

Fich = "d:\TestAdo.xls" 'à adapter

'écrit dans le classeur fermé la valeur des cellules A1:A5
'du classeur actif
For Each cell In ActiveWorkbook.Sheets("Feuil1").Range("A1:A5")
SetExternalDatas Fich, "Feuil1", cell.Address(0, 0), cell.Text
Next

'écrit en A6 la date et l'heure de l'opération
SetExternalDatas Fich, "Feuil1", "A6", "mise à jour du " & Now

'on regarde le résultat
DoEvents
Workbooks.Open Fich

End Sub

'écrit DataToWrite dans la cellule DestCellAdr
'de la feuille DestFeuille du classeur fermé DestFile
Sub SetExternalDatas(DestFile As String, _
DestFeuille As String, _
DestCellAdr As String, _
DataToWrite As Variant)
Dim oConn As ADODB.Connection
Dim oCmd As ADODB.Command
Dim oRS As ADODB.Recordset
Dim RangeDest
'd'après Rob Bovey, mpep

' Open a connection to the Excel spreadsheet
Set oConn = New ADODB.Connection
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DestFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;"";"

' Create a command object and set its ActiveConnection
Set oCmd = New ADODB.Command
oCmd.ActiveConnection = oConn

' This SQL statement selects a cell range in the "feuilleTest" worksheet.
'1 Sélection pour écrire dans une seule cellule
RangeDest = DestCellAdr & ":" & DestCellAdr
oCmd.CommandText = "SELECT * from `" & DestFeuille & "$" & RangeDest & "`"

' Open a recordset containing the worksheet data.
Set oRS = New ADODB.Recordset
oRS.Open oCmd, , adOpenKeyset, adLockOptimistic

' Update last row
oRS(0).Value = DataToWrite
oRS.Update

'Close the connection
oConn.Close
Set oConn = Nothing
Set oCmd = Nothing
Set oRS = Nothing

End Sub

à bientôt

 

[magic-dd]

Re : Recuperation de date qui ne fonctionne pas bien

merci pour ta contribution mais le probleme est que je dois piocher dans plusieurs classeurs excel pour alimenter le mien

je vais essayer d'adapter

mais sinon merci

 

[Bebere]

Re : Recuperation de date qui ne fonctionne pas bien

bonjour magicdd
dans pièce jointe 3 manières d'aller chercher des données
tu choisis le dossier et le fichier
à bientôt