Xin hướng dẫn tạo thư mục chính và thư mục con bằng vba excel

MyExcel Liên hệ QC

eherols

Thành viên mới
Tham gia
17/8/21
Bài viết
15
Được thích
1
Xin mọi người giúp đỡ code trường hợp sau, em có 01 userform như hình, em muốn tạo một thư mục mẹ có tên theo Textbox1 và thư mục con có tên theo textbox2 thì làm như thế nào ạ?
Em xin cám ơn ạ.
Untitled.png
 

johnnylinhanh

Thành viên thường trực
Tham gia
18/12/11
Bài viết
231
Được thích
175
Nghề nghiệp
Kiểm toán
Xin mọi người giúp đỡ code trường hợp sau, em có 01 userform như hình, em muốn tạo một thư mục mẹ có tên theo Textbox1 và thư mục con có tên theo textbox2 thì làm như thế nào ạ?
Chắc là như vầy đi? Bạn check code bên dưới thử xem
Rich (BB code):
 Sub CreateFolder()
 Dim Path$
 Set fso = CreateObject("Scripting.Filesystemobject")
 Path = ThisWorkbook.Path
 If Not fso.FolderExists(Path & "\" & Me.Textbox1.value) Then
    fso.createfolder (Path & "\" & Me.Textbox1.value))
 End If
 If Not fso.FolderExists(Path & "\" & Me.Textbox1.value & "\" & Me.Textbox2.value) Then
    fso.createfolder (Path & "\" & Me.Textbox1.value & "\" & Me.Textbox2.value)
 End If
End sub
 
Upvote 0

HeSanbi

0 + Giao động -> Vũ Trụ
Tham gia
24/2/13
Bài viết
1,867
Được thích
2,482
Giới tính
Nam
Bạn có thể tham khảo hàm tạo Folder dưới đây:

Call CreateFolder("C:\ThuMucMe" & "\" & "ThuMucCon")

JavaScript:
Sub btnCreateFolder()
    MsgBox  IIf( CreateFolder(TextBox1 & "\" & TextBox2), "Thanh cong", "Da da Loi")
End Sub

Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, Tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If VBA.Right(tFolder, 1) = "\" Then tFolder = VBA.Left(tFolder, VBA.Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = VBA.Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = VBA.Split(tFolder, "\")
  If FileSystem Is Nothing Then
    Set FileSystem = VBA.CreateObject("Scripting.FileSystemObject")
  End If
  On Error GoTo Ends
  FolderArray(0) = VBA.Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      Tmp = Tmp & FolderArray(i) & "\"
      If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function
 
Upvote 0

eherols

Thành viên mới
Tham gia
17/8/21
Bài viết
15
Được thích
1
Chắc là như vầy đi? Bạn check code bên dưới thử xem
Rich (BB code):
 Sub CreateFolder()
 Dim Path$
 Set fso = CreateObject("Scripting.Filesystemobject")
 Path = ThisWorkbook.Path
 If Not fso.FolderExists(Path & "\" & Me.Textbox1.value) Then
    fso.createfolder (Path & "\" & Me.Textbox1.value))
 End If
 If Not fso.FolderExists(Path & "\" & Me.Textbox1.value & "\" & Me.Textbox2.value) Then
    fso.createfolder (Path & "\" & Me.Textbox1.value & "\" & Me.Textbox2.value)
 End If
End sub
Dạ, em cám ơn bác nhé
Bài đã được tự động gộp:

Bạn có thể tham khảo hàm tạo Folder dưới đây:

Call CreateFolder("C:\ThuMucMe" & "\" & "ThuMucCon")

JavaScript:
Sub btnCreateFolder()
    MsgBox  IIf( CreateFolder(TextBox1 & "\" & TextBox2), "Thanh cong", "Da da Loi")
End Sub

Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, Tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If VBA.Right(tFolder, 1) = "\" Then tFolder = VBA.Left(tFolder, VBA.Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = VBA.Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = VBA.Split(tFolder, "\")
  If FileSystem Is Nothing Then
    Set FileSystem = VBA.CreateObject("Scripting.FileSystemObject")
  End If
  On Error GoTo Ends
  FolderArray(0) = VBA.Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      Tmp = Tmp & FolderArray(i) & "\"
      If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function
em cám ơn bác ạ
 
Upvote 0
Web KT

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL
Top Bottom