Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
700 connectés 

 


 Mot :   Pseudo :  
 
 Page :   1  2
Page Suivante
Auteur Sujet :

macro excel pour récupérer cellules

n°2090458
kiki29
Posté le 20-07-2011 à 19:45:24  profilanswer
 

Reprise du message précédent :
Salut, un exemple à adapter qui retourne le nom des feuilles d'un classeur
ShDatas étant le CodeName de la feuille recevant ici les noms des feuilles du fichier passé dans sNom
de la procédure ListeNomFeuilles
Affecter un bouton à SelFichier


'   Références  Microsoft ADO Ext. 2.8 for DLL and Security
'               Microsoft ActiveX Data Objects 2.x Library
 
Option Explicit
 
Sub SelFichier()
Dim Fichier As Variant
 
    ChDir ThisWorkbook.Path
 
    Fichier = Application.GetOpenFilename("Fichier xls (*.xls), *.xls" )
    If Fichier <> False Then
        Application.ScreenUpdating = False
        ListeNomFeuilles (Fichier)
        Application.ScreenUpdating = True
    End If
End Sub
 
Private Sub ListeNomFeuilles(sNom As String)
Dim Conn As Object
Dim Cat As Object
Dim FeuilleXL As Object
Dim iRow As Long
 
    ShDatas.Cells.Clear
    Set Conn = CreateObject("ADODB.Connection" )
    Set Cat = CreateObject("ADOX.Catalog" )
 
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sNom & ";Extended Properties=Excel 8.0;"
 
    Set Cat.ActiveConnection = Conn
 
    iRow = 1
    For Each FeuilleXL In Cat.Tables
        Select Case Right$(FeuilleXL.Name, 1)
            Case "$"
                ShDatas.Cells(iRow, 1) = Left$(FeuilleXL.Name, Len(FeuilleXL.Name) - 1)
                iRow = iRow + 1
            Case "'"
                ' Nom de feuille comportant des espaces
                ShDatas.Cells(iRow, 1) = Mid$(FeuilleXL.Name, 2, Len(FeuilleXL.Name) - 3)
                iRow = iRow + 1
        End Select
    Next FeuilleXL
 
    Conn.Close
    Set Conn = Nothing
    Set Cat = Nothing
End Sub


Message édité par kiki29 le 20-07-2011 à 22:30:44

---------------
Myanmar 90/91 : http://gadaud.gerard.free.fr/publi [...] index.html
mood
Publicité
Posté le 20-07-2011 à 19:45:24  profilanswer
 

n°2114011
ll46
Posté le 30-11-2011 à 11:49:22  profilanswer
 

Bonjour,  
 
Merci beaucoup pour le code (mis à jour du 9 août 2007) qui correspond parfaitement à mon problème. Cependant je suis incapable de le faire marcher pour des fichiers "csv" qui ne comportent qu'une seule feuille et dont le nom n'est pas "feuil1". Votre réponse (cf. cidessous) ne fonctionne pas et je n'arrive pas à corriger.  
J'en ai vraiment besoin et par avance merci MERCI beaucoup de votre aide  
 
 
 

kiki29 a écrit :

Salut, vite fait , à adapter à ton contexte


Option Explicit
.....
Dim NomFeuille As String
Const TypeFichier As String = "xls"
 
Dans procédure ListeFichiersDans
    .....
    For Each Fichier In DossierSource.Files
        If UCase(FSO.GetExtensionName(Fichier)) = UCase(TypeFichier) Then
  .....
        End If
    Next Fichier
    .....
 
Dans btnImport_QuandClic
    .....
    For i = 1 To NbFichiers
        NomFichier = ShImport.Range("A" & NumeroLigne)
        NomFeuille = Left$(ShImport.Range("A" & NumeroLigne), 15)
 .....
    Next i
    .....



 
 
 
 

n°2114054
kiki29
Posté le 30-11-2011 à 15:32:10  profilanswer
 

Salut, les macros proposées sont pour des fichiers XLS, pour des CSV j'ai ceci mais je pense qu'il y a mieux
 
Affecter un bouton à SelDossier
 

Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim TabFichiers() As String, NbFichiers As Long
Dim sNom As String
 
Sub SelDossier()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            NbFichiers = 0
            ShDatas.Cells.Clear
            LectureFichiersCSV .SelectedItems(1)
        End If
    End With
End Sub
 
Private Sub LectureFichiersCSV(sDossier As String)
Dim sChemin As String, sFichier As String
Dim iNumFree As Integer, i As Long
Dim  j As Long
Dim Wkb As Workbook
 
    Application.StatusBar = ""
    QueryPerformanceCounter Debut
    Close
 
    sChemin = sDossier
    iNumFree = FreeFile
 
    Application.ScreenUpdating = False
    sNom = "Lecture CSV.csv"
 
    '   Recherche   Récursive  ListeFichiersDossier sDossier, True
    '               Non Récursive  ListeFichiersDossier sDossier, False
    ListeFichiersDossier sDossier, True
    If NbFichiers = 0 Then Exit Sub
 
    j = 1
    For i = 1 To UBound(TabFichiers)
        sFichier = TabFichiers(i)
        Set Wkb = Workbooks.Open(Filename:=sFichier, Local:=True)
        With ShDatas
            .Range("A" & j) = Wkb.Worksheets(1).Range("A1" )
            .Range("B" & j) = Wkb.Worksheets(1).Range("B3" )
        End With
        j = j + 1
        Wkb.Close
        Application.StatusBar = i & " / " & NbFichiers
    Next i
 
    Set Wkb = Nothing
    Erase TabFichiers
 
    Application.ScreenUpdating = True
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Application.StatusBar & " : " & Format((Fin - Debut) / Freq, "0.00 s" )
 
End Sub
 
Private Sub ListeFichiersDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, sFichier As String
Dim sPath As String, Pos As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject" )
    Set Dossier = FSO.GetFolder(sChemin)
 
    sFichier = Dir$(sChemin & "\*.csv" )
    Do While Len(sFichier) > 0
        Pos = InStrRev(sFichier, "\" )
        If Right$(sFichier, Len(sFichier) - Pos) <> sNom Then
            sPath = sChemin & "\" & sFichier
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabFichiers(1 To NbFichiers)
            TabFichiers(NbFichiers) = sPath
        End If
        sFichier = Dir$()
    Loop
 
    If bInclureSousDossiers Then
        For Each Dossier In Dossier.SubFolders
            ListeFichiersDossier Dossier.Path, True
        Next Dossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub


Message édité par kiki29 le 02-12-2011 à 15:01:27

---------------
Myanmar 90/91 : http://gadaud.gerard.free.fr/publi [...] index.html
n°2118592
mclav
Posté le 28-12-2011 à 20:06:18  profilanswer
 

Sans utiliser le nom de la feuille ("Feuil1" par exemple), on peut alors utiliser le rang de la feuille.
Par exemple pour la première feuille, on place le chiffre "1" entre parenthèses, au lieu du nom de la feuille.
.Sheets(1)
 
De même, mais ce n'est pas la réponse demandée, on peut utiliser ce rang pour demander le nom de la feuille :
.Sheets(1).Name
 
Bon courage !
 

ll46 a écrit :

Bonjour,  
 
Merci beaucoup pour le code (mis à jour du 9 août 2007) qui correspond parfaitement à mon problème. Cependant je suis incapable de le faire marcher pour des fichiers "csv" qui ne comportent qu'une seule feuille et dont le nom n'est pas "feuil1". Votre réponse (cf. cidessous) ne fonctionne pas et je n'arrive pas à corriger.  
J'en ai vraiment besoin et par avance merci MERCI beaucoup de votre aide  
 
[i]


Message édité par mclav le 28-12-2011 à 20:07:44
n°2125402
varik
Posté le 08-02-2012 à 14:20:10  profilanswer
 

Bonjour tout le monde !!
 
je viens vous voir car je dois écrire sur des fichiers un ensemble de fichiers excel (7000) qui sont placé dans des répertoires et sous répertoires .
 
je voulais savoir si je pouvais m'inspirer du code cité dans le forum afin d'écrire directement sur les cellules que je veux:
 
Option Explicit  
 
Dim NbFichiers As Long  
Dim DossierOk As String  
 
Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)  
Dim FSO As Scripting.FileSystemObject  
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder  
Dim Fichier As Scripting.File  
Dim Extension As String  
Dim r As Long, VerifNom As Boolean  
 
    Set FSO = New Scripting.FileSystemObject  
    Set DossierSource = FSO.GetFolder(NomDossierSource)  
 
    r = ShImport.Range("A65536" ).End(xlUp).Row + 1  
 
    For Each Fichier In DossierSource.Files  
        VerifNom = UCase(Fichier.Name) Like UCase(NomFichierRch)  
        If VerifNom Then  
            With ShImport  
                .Cells(r, 1)= Fichier.Name  
                .Cells(r, 2)= Fichier.ParentFolder  
                .Cells(r, 3)= Fichier.DateCreated  
                .Cells(r, 4)= Fichier.Size  
                NbFichiers = NbFichiers + 1  
                r = r + 1  
            End With  
            Application.StatusBar = "Lecture noms : " & r  
        End If  
    Next Fichier  
 
    If InclureSousDossiers Then  
        For Each SousDossier In DossierSource.SubFolders  
            ListeFichiersDansDossier SousDossier.Path, True  
        Next SousDossier  
        Set SousDossier = Nothing  
    End If  
 
    ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C5"  
    ' Si cellule Z3 remplacer la ligne ci-dessus par  
    'ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C6"  
 
    Set DossierSource = Nothing  
    Set FSO = Nothing  
 
End Sub  
 
Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, _  
                                ByVal Feuille As String, ByVal Cellule As String)  
 
j'attend vos réflexion car je commence en VB et j'avoue qu'il y a pas mal de truc que j'ai pas encore compris


Message édité par varik le 08-02-2012 à 15:05:41
n°2169768
MdS59
Posté le 03-01-2013 à 18:32:13  profilanswer
 

emeric27 a écrit :

Merci pour votre aide, je ne suis pas revenu vers vous car j'ai fini par trouver la solution.


 
Bonjour,
 
Pouvez vous me communiquer la solution ?
 
Merci

n°2169770
MdS59
Posté le 03-01-2013 à 18:34:21  profilanswer
 

kiki29 a écrit :

Salut, vite fait , à adapter à ton contexte


Option Explicit
.....
Dim NomFeuille As String
Const TypeFichier As String = "xls"
 
Dans procédure ListeFichiersDans
    .....
    For Each Fichier In DossierSource.Files
        If UCase(FSO.GetExtensionName(Fichier)) = UCase(TypeFichier) Then
  .....
        End If
    Next Fichier
    .....
 
Dans btnImport_QuandClic
    .....
    For i = 1 To NbFichiers
        NomFichier = ShImport.Range("A" & NumeroLigne)
        NomFeuille = Left$(ShImport.Range("A" & NumeroLigne), 15)
 .....
    Next i
    .....



 
Bonjour,
 
A la place du type de fichier, j'aimerais creer un masque sur le nom de fichier du style FS_*.xls
 
Auriez vous une idées de comment faire cela ?
 
Merci

n°2169812
boomy29
PSN: tintine29
Posté le 04-01-2013 à 10:00:02  profilanswer
 

perso je rajouterai un test  
si les 3 1er caractere de fichier.name = FS_
 
et voila

n°2264684
dr_froggy
Posté le 22-08-2015 à 15:13:34  profilanswer
 

Bonjour a tous, et a toutes,
 
je me permets de vous demander assistance, je ne suis pas fait pour faire de la prog. J avais deja essaye de me mettre a l epoque au html et php... Mais sans succes. par contre je detectais les erreurs de codes fait par d autres...
 
Enfin, ceci dit, j ai toujours pense que le vba et les macros pouvaient m aider mais a chaque fois meme en utilisant la fonction macro recorder... ca part en cacahouete... bug en ligne 9...
Dernierement, j ai essaye de mettre en place une macro avec le recorder (sur un pc avec OS en allemand):
Ca se rapproche de ce qu il a ete demande ici, je pense. Ci dessous ce que j essayais d obtenir 2fichiers, toujours en feuille 1).
 
-workbook 1 "Calcul sur data" --> on renseigne ici l'ID d une caracteristique en colonne A et les pourcentages en colonne B
la macro sert a recuperer/ copier des parametres supplementaires dans le workbook 2 pour chaque ID renseignee dans le workbook1 et de les coller dans la colonne C.
On demande ensuite a la macro d effectuer des operations (faire somme / integrale / variance)  ou de multiplier et diviser la colonne B avec la colone C et donner le resultat pour chque ID en colonne D)
 
-Workbook  "Source data". Contient une liste de 500 ID ou plus (par exemple) et pour chaque ID on a un parametre ayant une valeur  par exemple age / Poids / hauteur.
 
Du Coup, j ai tente d enregistrer une macro. en faisant la chose suivante (apres avoir importer un masque pour le premier exemple seulement j ai demarrer la macro juste apres): premiere etape dans "calcul de data" - rechercher "article Nr" puis je ferme la recherche. je suis donc bien sur la cellule article Nr. je descends avec la fleche d une cellule. -->premiere ID se trouve en dessous.
Copier "ID1". (le dossier source data est deja ouvert)  
changer de fenetre active "source data", lancer une recherche valeur "ID1" copiée, la cellule avec ID1 est trouvee. on ferme la recherche, je deplace avec la fleche droite sur la meme ligne jusqu a la colonne desiree (parametre hauteur par exemple valeur "H1" ), je copie la cellule,  
Je change de fenetre active. je lance une recherche (ID1 est toujours present) je ferme la recherche je suis sur la cellule ID1 du workbook1 donc. je me deplace avec la fleche, pour aller en colonne C. je colle ici la valeur H1.  
je recherche ID1 (qui est toujours par defaut dans la recherche) dans workbook 1. cette fois ci je descends d une case. et je suis en ID2.
 
je fais la meme chose avec ID2 (valeur "H2" dans workbook 2- "source data" ) et ainsi de suite jusqu a ce que sur workbook1 je passe de IDy (y un entier ici ca pourrait etre 3 comme ca pourrait etre 851 - osef :-P c est just pour l exemple - y est le dernier ID) a une case en dessous ou il n a plus de valeur en gros une cellule vide.
La je m arrete de faire des recherche et je passe au calcul je fais la somme de la colonne ID1 a IDy puis je fais une multiplication de ID1 avec H1 avec resultat en colonne D (ID1H1).  
$$$$$Pour rappel, la colonne en C n existait pas et est le resultat de la "macro a la main" qui a extraite les donnees depuis le fichier source data. j ai fait cela pour 3 ID en fait)
 
ID1 IDy ont des designations qui sont similaires mais les valeurs ne sont pas forcement donnes dans l ordre croissant$$$$$$
 
 
Je fais la somme de IDyHy dans la cellule en dessous IDyHy  
 
Fin - je stoppe l enregistrement de la macro, je l enregistre.
 
Je change les valeurs ID1 a IDy qui correspondent donc a d autres valeurs H1 a Hy dans workbook 2... et la ca ne marche pas.
Mais alors pas du tout. quand je regarde le code. je me dis que VBA macro recorder n a pas capter qu il doit copier la valeur et ne pas l integrer au code mais l utiliser pour les etapes. Or dans ce code la valeur est donnee. donc a fortiori il a copie une valeur est fixe dans le code au lieu d etre une variable.
de plus je ne sais pas comment faire pour indiquer au programme que SI (IF) dans Workbook 1 on passe de la case IDy a une case vide en dessous, ALORS (THEN) on passe a la phase de calcul....
De plus il me faudrait un code pour au cas ou une valeur est manquante --> qu il me mette genre une valeur nulle, mais en mettant une mention dans une autre colonne vide. Pour eviter que le script stoppe prematurement parce qu un argument est manquant.
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
Je remercie d avance tous ceux qui prendront le temps de repondre a mon post et me proposer un code qui devrait fontionner de la maniere decrite"
 
ci dessous le code obtenu. (ID1 possede la valeur "RM01" )
 
 
Sub TestCalculation()
 
'
 
' TestCalculation Makro
 
'
 
 
 
'
 
    Cells.Find(What:="article Nr", After:=ActiveCell, LookIn:=xlFormulas, _
 
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
 
        MatchCase:=False, SearchFormat:=False).Activate
 
    Range("B2" ).Select
 
    Selection.Copy
 
    Windows("source data.xlsx" ).Activate
 
    Cells.Find(What:="RM01", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("D2" ).Select
 
    Application.CutCopyMode = False
 
    Selection.Copy
 
    Windows("data.xlsx" ).Activate
 
    Range("B2" ).Select
 
    Cells.Find(What:="RM01", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("F2" ).Select
 
    ActiveSheet.Paste
 
    Cells.Find(What:="RM01", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("B3" ).Select
 
    Application.CutCopyMode = False
 
    Selection.Copy
 
    Windows("source data.xlsx" ).Activate
 
    Cells.Find(What:="RM05", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("D6" ).Select
 
    Application.CutCopyMode = False
 
    Selection.Copy
 
    Windows("data.xlsx" ).Activate
 
    Cells.Find(What:="RM05", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("F3" ).Select
 
    ActiveSheet.Paste
 
    Cells.Find(What:="RM05", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("B4" ).Select
 
    Application.CutCopyMode = False
 
    Selection.Copy
 
    Windows("source data.xlsx" ).Activate
 
    Cells.Find(What:="RM03", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("D4" ).Select
 
    Application.CutCopyMode = False
 
    Selection.Copy
 
    Windows("data.xlsx" ).Activate
 
    Cells.Find(What:="RM03", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("F4" ).Select
 
    ActiveSheet.Paste
 
    Cells.Find(What:="RM03", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
 
        False, SearchFormat:=False).Activate
 
    Range("B5" ).Select
 
    Application.CutCopyMode = False
 
    Selection.Copy
 
    Range("D7" ).Select
 
    Application.CutCopyMode = False
 
    ActiveCell.FormulaR1C1 = "=SUMME"
 
    Range("D7" ).Select
 
    ActiveCell.FormulaR1C1 = "=SUM(R[-5]C:R[-3]C)"
 
    Range("E2" ).Select
 
    ActiveCell.FormulaR1C1 = "=RC[-1]/R[5]C[-1]"
 
    Range("E2" ).Select
 
    Selection.Copy
 
    Range("E3" ).Select
 
    Range("E2" ).Select
 
    Application.CutCopyMode = False
 
    ActiveCell.FormulaR1C1 = "=RC[-1]/R7C4"
 
    Range("E3" ).Select
 
    ActiveCell.FormulaR1C1 = "=RC[-1]/R7C4"
 
    Range("E3" ).Select
 
    Selection.Copy
 
    Range("E4" ).Select
 
    ActiveSheet.Paste
 
    Range("G2" ).Select
 
    Application.CutCopyMode = False
 
    ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-2]"
 
    Range("G2" ).Select
 
    Selection.Copy
 
    Range("G3" ).Select
 
    ActiveSheet.Paste
 
    Range("G4" ).Select
 
    ActiveSheet.Paste
 
    Range("G5" ).Select
 
    ActiveSheet.Paste
 
    Range("G7" ).Select
 
    Application.CutCopyMode = False
 
    ActiveCell.FormulaR1C1 = "=SUM(R[-5]C:R[-3]C)"
 
    Range("H7" ).Select
 
    ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-7]"
 
    Range("H7" ).Select
 
    ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-7]"
 
    Range("H8" ).Select
 
End Sub

n°2264986
dr_froggy
Posté le 30-08-2015 à 09:20:12  profilanswer
 

Bonjour n y a t il personne pour me filer un coup de main ( pas une claque j entends :D) merci de vos reponses

mood
Publicité
Posté le 30-08-2015 à 09:20:12  profilanswer
 

n°2265000
Marc L
Posté le 30-08-2015 à 17:23:57  profilanswer
 

 
            Non car non respect des règles du forum …   Et qui plus est cross-posting sauvage !
 

mood
Publicité
Posté le   profilanswer
 

 Page :   1  2
Page Suivante

Aller à :
Ajouter une réponse
 

Sujets relatifs
insertion de donnée dans tableau excel en phpSortie etat excel
Tableau Excel en phpN° de ligne de l'intersection de 2 cellules
Excel VBA - Double cliqueecrire un long titre dans une page excel en php
outils pour récupérer infos dans code htmlenorme probleme excel
[JavaScript] Récupérer les attributs d'une classe ?recupérer la date d'hier
Plus de sujets relatifs à : macro excel pour récupérer cellules


Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR