2 pièce(s) jointe(s)
Insérer un tableau dans excel grâce à une fonction et non une procédure
Hello la team,
Je me confronte à un petit problème depuis un moment. J'ai fais une fonction excel permettant de récupérer des données( données financières : donc date en 1er colonne et le reste) sur d'autres fichiers, via une filtre de date avec une date de début et une date de fin.
L'objectif final étant de mettre cette fonction dans une macro complémentaire afin d’être utilisé sur l'ensemble des classeurs
Le problème est que je n'arrive pas à la faire fonctionner sur excel( ça me sort un value), je suis obligé de passer par une procédure ( worksheet change ) mais cette méthode ne convient pas vraiment, il me faudrait une fonction !
C'est une imitation d'une fonction bloomberg type BDH pour ceux qui connaissent!
Auriez-vous une feinte ?
J'ai mise un fichier avec la macro et un fichier "ticker1" : c'est le fichier qui contient les données que la fonction doit interroger
Voici voulou, j'espère que j'étais assez claire
Merci à vous
Lucy
Code:
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
91
92
93
94
95
96
|
Public Function FichierExiste(MonFichier As String)
If MonFichier <> "" And Len(Dir(MonFichier)) > 0 Then
FichierExiste = True
Else
FichierExiste = False
End If
End Function
'-------------------------------------------------------------------------------------------------------
Public Function getdata(ticker As String, Datedebut As String, Datefin As String) As Variant
Application.ScreenUpdating = False
Dim FilePath As String
Dim wbTicker As Workbook
Dim wsTicker As Worksheet
Dim Rng As Range
Dim datas()
FilePath = "C:\" & ticker & ".xlsx"
If FichierExiste(FilePath) = False Then
MsgBox "Le fichier " & ticker & " n'existe pas dans la base, veuillez le créer!"
Exit Function
Else:
Set wbTicker = Workbooks.Open(FilePath)
Set wsTicker = wbTicker.Sheets("Feuil1")
With wsTicker
.AutoFilterMode = False
.Range("A2").AutoFilter Field:=1, Criteria1:=">=" & Format(Datedebut, "mm/dd/yyyy"), _
Operator:=xlAnd, Criteria2:="<=" & Format(Datefin, "mm/dd/yyyy"), VisibleDropDown:=False
On Error Resume Next
Set Rng = .AutoFilter.Range.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If Not Rng Is Nothing Then
With wbTicker.Worksheets.Add
Rng.Copy .Range("A1")
datas = .UsedRange.Value
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
getdata = datas
Else
MsgBox "Filtre sans résultat"
End If
wbTicker.Close SaveChanges:=False
End If
Application.ScreenUpdating = True
Set wbTicker = Nothing: Set wsTicker = Nothing:
End Function
'---------------------Partie Worksheet Change------------
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Excel.Range)
Dim datas As Variant
Dim ContenuInitial As String
Dim a() As String
Dim ticker As String, d1 As String, d2 As String
If Target.Count > 1 Then
Exit Sub
End If
ContenuInitial = Target.Value
If ContenuInitial Like "*,*,*" Then
a() = Split(ContenuInitial, ",")
ticker = a(0)
d1 = a(1)
d2 = a(2)
datas = getdata(ticker, d1, d2)
If datas <> "" Then
Target.Resize(UBound(datas, 1), UBound(datas, 2)).Value = datas
Else: Exit Sub
End If
Else: Exit Sub
End If
End Sub |
Pièce jointe 579771Pièce jointe 579773
