Sub createfolders()
Dim folder As String
Dim currentpath As Variant
Dim worddoc(3000, 2) As String
Dim docApp As New Word.Application
Dim docDoc As Word.Document
Set chk = CreateObject("Scripting.FileSystemObject")
If chk.FolderExists("D:\test") = False Then
MkDir "d:\test"
Else: MsgBox "路径已存在!"
Exit Sub
End If
RowCount = ActiveSheet.[b1].CurrentRegion.Rows.Count
For i = 1 To RowCount
folder = Cells(i, 2).Value
If folder <> "" Then
MkDir "D:\test\" + folder
currentpath = "D:\test\" + folder + "\"
Else
Exit Sub
End If
worddoc(i - 1, 0) = Cells(i, 3).Value
worddoc(i - 1, 1) = Cells(i, 4).Value
worddoc(i - 1, 2) = Cells(i, 5).Value
docApp.Visible = False
Set docDoc = docApp.Documents.Add
docDoc.SaveAs currentpath + worddoc(i - 1, 0) + ".doc"
docDoc.SaveAs currentpath + worddoc(i - 1, 1) + ".doc"
docDoc.SaveAs currentpath + worddoc(i - 1, 2) + ".doc"
docApp.DisplayAlerts = False
docDoc.Close
docApp.Quit
Set docDoc = Nothing
Set docApp = Nothing
Next i
End Sub