J'ai un fichier Excel avec des centaines de noms de clients et plusieurs numéros d'article.
Je veux vérifier si un dossier avec le nom de client sélectionné existe et créer un dossier s'il manque.
Une fois le dossier client trouvé ou créé, vérifiez s'il existe un dossier pour chaque numéro d'article et s'il manque, créez-en un.
J'ai trouvé du code qui semble faire tout cela et plus encore publié par Scott Holtzman .
J'ai référencé Microsoft Scripting Runtime comme requête de code.
Les deux instructions "If not" sont marquées en rouge et la fenêtre contextuelle indique uniquement "Erreur de compilation".
J'ai vérifié la syntaxe des instructions "If not" et elle semble correcte. p>
'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()
Dim strComp As String, strPart As String, strPath As String
strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"
If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strComp & "\" & strPart) Then
FolderCreate strPath & strComp & "\" & strPart
End If
End If
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/","")
CleanName = Replace(CleanName, "*","")
' etc...
End Function
4 Réponses :
Vous ne pouvez pas utiliser StrComp , c'est un mot réservé, en fait une fonction de chaîne. J'ai perdu environ 15 minutes l'autre jour sur ce problème.
VBA dit: Renvoie un Variant (Integer) indiquant le résultat d'une comparaison de chaînes.
En fait, vous pouvez utiliser la variable StrComp sans aucune limitation après avoir remplacé la fonction intrinsèque en déclarant Dim StrComp . Le compilateur s'arrête même pour le mettre en évidence comme un mot réservé.
@omegastripes: Je ne comprends pas ce que vous dites. Pourriez-vous nous en dire plus ou fournir un lien. BTW lorsque j'utilise 'Sub StrCompIssue () Dim StrComp StrComp = "The StrComp Issue" Debug.Print StrComp End Sub' avec ou sans Option Explicit, il déclenche 'Compile error: Syntax error' .
Je dois admettre que quelque chose me manque lors du test, donc après la déclaration Dim StrComp il est possible d'attribuer une valeur à la variable, mais il n'y a toujours pas de moyen possible d'utiliser cette variable. C'est pourquoi +1)
Si vous souhaitez raccourcir une partie de ce code, utilisez MKDIR pour créer chaque niveau de dossier \ sous-dossier avec un transfert d'erreur.
Option Explicit
Sub main()
Dim pth As String
pth = "c:\test\abc\123\test_again\XYZ\01-20-2019"
'folder may or may not exist
makeFolder pth
'folder definitely exists
End Sub
Sub makeFolder(fldr As String)
Dim i As Long, arr As Variant
'folder may or may not exist
arr = Split(fldr, Chr(92))
fldr = arr(LBound(arr))
On Error Resume Next
For i = LBound(arr) + 1 To UBound(arr)
fldr = Join(Array(fldr, arr(i)), Chr(92))
MkDir fldr
Next i
On Error GoTo 0
'folder definitely exists
End Sub
Jetez un œil à l'exemple ci-dessous, il montre l'une des approches possibles utilisant un sous-appel récursif:
Option Explicit
Sub TestArrays()
Dim aCustomers
Dim aArticles
Dim sCustomer
Dim sArticle
Dim sPath
sPath = "C:\Test"
aCustomers = Array("Customer01", "Customer02", "Customer03", "Customer04", "Customer05")
aArticles = Array("Article01", "Article02", "Article03", "Article04", "Article05")
For Each sCustomer In aCustomers
For Each sArticle In aArticles
SmartCreateFolder sPath & "\" & sCustomer & "\" & sArticle
Next
Next
End Sub
Sub TestFromSheet()
Dim aCustomers
Dim aArticles
Dim i
Dim j
Dim sPath
sPath = "C:\Test"
With ThisWorkbook.Sheets(1)
aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
aArticles = .Range("B1:B10").Value
End With
For i = LBound(aCustomers, 1) To UBound(aCustomers, 1)
For j = LBound(aArticles, 1) To UBound(aArticles, 1)
SmartCreateFolder sPath & "\" & aCustomers(i, 1) & "\" & aArticles(j, 1)
Next
Next
End Sub
Sub SmartCreateFolder(sFolder)
Static oFSO As Object
If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO
If Not .FolderExists(sFolder) Then
SmartCreateFolder .GetParentFolderName(sFolder)
.CreateFolder sFolder
End If
End With
End Sub
Sub TestArrays () vérifie et crée des dossiers pour les clients et les articles des tableaux codés en dur, et Sub TestFromSheet () récupère les clients et les articles de la première feuille de calcul, par exemple, les clients vont de A1 au dernier élément, il doit donc s'agir de plusieurs éléments là, et les articles définis sur la plage fixe B1: B10, comme indiqué ci-dessous:
Comment puis-je ajuster la partie du tableau aCustomer si je n'ai qu'un seul client actif à la fois? Actuellement, il a besoin d'au moins 2 clients.
aCustomers = Array ("Client01")
J'ai une cellule dans laquelle se trouve le nom du client (B7), Array ne veut pas accepter une seule valeur.
@HenryR J'ai mis à jour la réponse avec l'exemple de la façon d'obtenir des données source à partir de la feuille de calcul.
@omegastripes félicitations pour l'élégant SmartCreateFolder.
En ce qui concerne SmartCreateFolder - en fait, le mérite revient à @EBGreen, je viens d'ajouter une déclaration Static pour améliorer les performances.
@omegastripes ... et je l'ai `` emprunté '' et l'ai transformé en Fonction avec gestion des erreurs (pour d'éventuels caractères interdits)
Pourriez-vous élaborer sur la question statique.
Je voudrais ajouter la création d'un sous-dossier dans le dossier de l'article pour révision. Si j'ajoute cette ligne, cela crée un dossier supplémentaire avec révision à l'intérieur du dossier article et dans le dossier client. Comment puis-je modifier cela pour créer un dossier uniquement dans le dossier d'articles? aCustomers = Range ("A7: B7") aArticles = Range ("B11: B12") aRevs = Range ("H11: H12") Pour chaque client de aCustomers Pour chaque article de aArticles Pour chaque sRev dans aRevs SmartCreateFolder sPath & "\ "& sClient &" \ "& sArticle &" \ "& sRev
La déclaration @ VBasic2008 Static conserve simplement l'instance FSO en mémoire, ce qui contribue à améliorer les performances des appels multiples.
@HenryR Veuillez ne pas publier de bloc de code dans les commentaires. Mieux vaut poser une nouvelle question et décrire le résultat attendu, les émissions et le code dont vous disposez.
Pour renommer un fichier existant à un nouvel emplacement AVEC la création de tous les sous-répertoires, vous pouvez utiliser:
File_Name_OLD = File_Pad_OLD & "Test.txt" File_Pad_NEW = "e:\temp\test1\test2\test3\" File_Name_NEW = File_Pad_NEW & "Test.txt" X = File_Pad_NEW A = 1 Do Until A = 0 A = InStr(X, "\") Y = Y & Left(X, A) X = Mid(X, A + 1) If Dir(Y, 16) = "" Then MkDir Y Loop Name File_Name_OLD As File_Name_NEW
Ceci crée le nouveau chemin avec les sous-répertoires et renomme l'ancien fichier en le nouveau .
/ a> est une fonction VBA, renommer vos variables sera la solution
@Storax En fait, vous pouvez utiliser la variable
StrCompsans aucune limitation après avoir remplacé la fonction intrinsèque en déclarantDim StrComp. Le compilateur s'arrête même pour le mettre en évidence comme un mot réservé.