Giúp về tạo thư mục lưu trong VBA

[kazunoki]

Chào mọi người, Mình mới học VBA nên chưa có nhiều kiến thức cơ bản. Hiện tại mình đang có học mót 1 đoạn VBA để thay thế dữ liệu trong word. Đoạn mã chạy tốt tuy nhiên mình muốn lưu file trong 1 thư mục riêng biệt thì bị lỗi. Anh chị em nào rành xem giúp với mình cảm ơn trước

Sub Test()
    Dim sohang As Long
    Dim socot As Long
    Dim j As Long
    Dim Teamplate As Object
    Dim t As Object
    sohang = 3
    socot = 2
    With CreateObject("word.application")
        .Visible = True
            Set Template = .Documents.Open("D:\Work\BIDV\ABC.docx")
            Set t = Template.Content
            For j = 1 To sohang
                t.Find.Execute _
                    FindText:=Sheet1.Cells(j, 1).Value, _
                    ReplaceWith:=Sheet1.Cells(j, 2).Value, _
                    Replace:=wdReplaceAll
            Next
            Template.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.Cells(1, 2).Value & "\" & "123.docx"
        .Quit
    End With
    Set t = Nothing
    Set Template = Nothing
End Sub

 

[quanluu]

Chào mọi người, Mình mới học VBA nên chưa có nhiều kiến thức cơ bản. Hiện tại mình đang có học mót 1 đoạn VBA để thay thế dữ liệu trong word. Đoạn mã chạy tốt tuy nhiên mình muốn lưu file trong 1 thư mục riêng biệt thì bị lỗi. Anh chị em nào rành xem giúp với mình cảm ơn trước

Sub Test()
    Dim sohang As Long
    Dim socot As Long
    Dim j As Long
    Dim Teamplate As Object
    Dim t As Object
    sohang = 3
    socot = 2
    With CreateObject("word.application")
        .Visible = True
            Set Template = .Documents.Open("D:\Work\BIDV\ABC.docx")
            Set t = Template.Content
            For j = 1 To sohang
                t.Find.Execute _
                    FindText:=Sheet1.Cells(j, 1).Value, _
                    ReplaceWith:=Sheet1.Cells(j, 2).Value, _
                    Replace:=wdReplaceAll
            Next
            Template.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.Cells(1, 2).Value & "\" & "123.docx"
        .Quit
    End With
    Set t = Nothing
    Set Template = Nothing
End Sub

bạn thay thisworkbook.path bằng "₫ưong dẫn cụ thể"

 

[HeSanbi]

Bạn thêm đoạn code dưới đây vào để thực hiện tạo Folder:

CreateFolder ThisWorkbook.Path & "\" & Sheet1.Cells(1, 2).Value
Template.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.Cells(1, 2).Value & "\" & "123.docx"

Function CreateFolder(ByVal FolderPath$) As Boolean
  Dim FolderArray, Tmp$, item, tFolder$
  tFolder = FolderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
  On Error GoTo Ends
  With CreateObject("Scripting.FileSystemObject")
    For Each item In FolderArray
      Tmp = Tmp & item & "\"
      If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
    Next
  End With
  CreateFolder = True
Ends:
End Function

 

[kazunoki]

Bạn thêm đoạn code dưới đây vào để thực hiện tạo Folder:

CreateFolder ThisWorkbook.Path & "\" & Sheet1.Cells(1, 2).Value
Template.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.Cells(1, 2).Value & "\" & "123.docx"

Function CreateFolder(ByVal FolderPath$) As Boolean
  Dim FolderArray, Tmp$, item, tFolder$
  tFolder = FolderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
  On Error GoTo Ends
  With CreateObject("Scripting.FileSystemObject")
    For Each item In FolderArray
      Tmp = Tmp & item & "\"
      If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
    Next
  End With
  CreateFolder = True
Ends:
End Function

thanks bác nhiều nhé mình làm được rồi

 

[huhumalu]

thanks bác nhiều nhé mình làm được rồi

Từ 2019 tới giờ mới nhận được hồi âm.
Hix, còn hơn cả người yêu cũ.

 

[kazunoki]

Từ 2019 tới giờ mới nhận được hồi âm.
Hix, còn hơn cả người yêu cũ.

được ae ý kiến k thấy rep nên chạnh lòng bác ạ.