Creation dossier à partir du nom d'une cellule

Bonjour à tous,

Je sollicite votre aide car j'ai beaucoup de mal à créer un code vba

Prérequis : créer un dossier à l'endroit ou se situe le fichier excel.

Prérequis : ce dossier sera créé à partir d'une valeur de cellule ici la cellule B:6 ou la cellule sélectionnée , valeur test.tar.gz

Prérequis : le nom de ce dossier sera ensuite renommé pour s’appeler "test" donc l'extension .tar.gz serait supprimé

Après je n'ose pas aller plus loin dans mes demandes car ce sera déjà un grand merci de votre part de m'aider dans ces étapes.

Je précise que j'adapterais ensuite ce code pour un fichier au travail donc les données ne sont pas ce qu'elles sont dans le fichier excel joint ici.

J'ai trouvé un code vba sur le net mais je suis coincé pour le renommage comme précisé ci-dessus.

Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Par avance merci pour l'aide que vous pourrez m'apporter.

Guibs

Hello,

J'ai pas regardé le fichier ni fait de test

Mais si tu souhaites renommer un fichier voici :

FichierOriginal = "C:\toto.xlsx"
FichierCopie = "C:`\tata.xlsx"

FileCopy FichierOriginal, FichierCopie

Cependant, méfiance avec les Dir Mkdir ...

Bonjour,

Déjà merci pour ta réponse. Cependant je ne pense pas que ta solution s'adapte avec le code ci-dessous. En effet, le mkdir crée le dossier à partir d'une sélection de cellule. Ce dont il serait bien dans mon cas pour la création du dossier c'est reprendre ce nom de valeur dans la cellule test.tar.gz et enlever la fin de ce nom qui se termine en .tar.gz

Voila pour la précision et m'indiquer ou mettre ce bout de code dans le code ci-dessous

Sub Creation_dossier_Cliquer_dessus()

Dim Rng As Range

Dim maxRows, maxCols, r, c As Integer

Set Rng = Selection

maxRows = Rng.Rows.Count

maxCols = Rng.Columns.Count

For c = 1 To maxCols

r = 1

Do While r <= maxRows

If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then

MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))

On Error Resume Next

End If

r = r + 1

Loop

Next c

MsgBox "Le dossier a été créé à l'endroit où se situe la description des données"

End Sub

hello,

pour remplacer tu texte dans une cellule tu peux utiliser la fonction replace, ici je modifie la cellule a1 en remplaçant ".xlsx" par ".xlsm"

[A1] = Replace([A1], ".xlsx", ".xlsm")

Bonjour Rag,

Alors voici mes recherches qui avancent petit à petit.

J’apprécie tes réponses cependant j'ai manqué de précision dans mes demandes. En fait il faudrait que l'attendu voulu soit exécuté à partir de la commande vba "mkdir" ci-dessous dans le code :

Pour le moment, j'arrive à supprimer "tar.gz" maintenant il faudrait que j'arrive à supprimer le "YYYYMMDDHHMMSS_" et le faire remplacer par un vrai timestamp.

Hello,

Sub Renommer()

    Dim PosUnderscore             As Byte
    Dim TimeStamps                As String
    Dim txtARemplacer             As String

    Dim PosPoint                  As Byte
    Dim Extension                 As String

    ' ++++++++++  Remplace le timestamp  en B7 +++++++++++++++

    PosUnderscore = InStr(1, [B6], "_")                             ' Cherche underscore
    txtARemplacer = Left([B6], (PosUnderscore - 1))                 ' Txt avant l'underscore
    TimeStamps = Format(Now, "YYYYddMMhhMMss")                      ' Format TimeStamp
    [B7] = Replace([B6], txtARemplacer, TimeStamps)                 ' Remplace le txt dans B7

    ' ++++++++++  Remplace l'extension  en B8 +++++++++++++++

    PosPoint = InStr(1, [B7], ".")                                  ' Cherche Point
    txtARemplacer = Right([B7], (Len([B7]) - PosPoint))             ' Txt apres le point
    Extension = "xlsx"                                              ' Format extension
    [B8] = Replace([B7], txtARemplacer, Extension)                  ' Remplace le txt dans B8

End Sub

Merci à toi Rag,

La on a du sophistiqué lol

Je ne suis pas sur de pouvoir l'implémenter dans le petit bout de code déjà tout fait. C'est pourquoi j'ai essayé de bricoler un peu. Avec ce code :

Sub Creation_dossier_Cliquer_dessus()
Dim cell As Range
On Error Resume Next
For Each cell In Selection
If Len(Dir(ThisWorkbook.Path & "\" & cell.Value, vbDirectory)) = 0 Then
MkDir ((ThisWorkbook.Path & "\" & Format(Now, "YYYYMMddhhMMss_")) & Left(cell.Value, Application.WorksheetFunction.Find("YYYYMMDDHHMMSS", cell.Value) - 1) & Left(cell.Value, Len(cell.Value) - 6))
End If
Next cell
On Error GoTo 0
MsgBox "Le dossier a été créé à l'endroit où se situe la description des données"
End Sub

Malheureusement, je n'obtiens pas le résultat escompté. Le fameux timestamp YYYYMMDDHHMMSS reste toujours présent. Mon .tar.gz est bien lui absent comme prévu. Décidément je sèche.

Re-bonjour Rag,

Bon voilà j'ai ma solution a force d'avoir cherché comme un dingue.

Voici le code et l'attendu est celui auquel j'escomptais.

Sub Creation_dossier_Cliquer_dessus()
Dim cell As Range
On Error Resume Next
For Each cell In Selection
If Len(Dir(ThisWorkbook.Path & "\" & cell.Value, vbDirectory)) = 0 Then
MkDir (((ThisWorkbook.Path & "\" & Format(Now, "YYYYMMddhhMMss_")) & Replace(Replace(cell.Value, "YYYYMMDDHHMMSS_", ""), ".tar.gz", "")))
End If
Next cell
On Error GoTo 0
MsgBox "Le dossier a été créé à l'endroit où se situe la description des données"
End Sub

Je te remercie pour tout Rag et merci d'y avoir consacré du temps. Ta solution est sans doute très bonne mais dans mon cas il aurait fallu que je reprenne tout. Le but ici étant de tout mettre à l’enchaînement dans la commande mkdir.

Pas de soucis

A+