Hallo allemaal,
De onderstaande macro werkt prima, behalve in het ELSE gedeelte bij het SaveAs gaat het fout.
Ik krijg een run time error 438
Object doesn't support this property or method
Ik heb geen idee hoe ik het dan wel zou moeten oplossen.
De macro kijkt of de file al bestaat, zo niet dan een nieuwe file maken, waarden er in zetten en dan een SaveAs de nieuwe naam.
Alvast bedankt.
De onderstaande macro werkt prima, behalve in het ELSE gedeelte bij het SaveAs gaat het fout.
Ik krijg een run time error 438
Object doesn't support this property or method
Ik heb geen idee hoe ik het dan wel zou moeten oplossen.
De macro kijkt of de file al bestaat, zo niet dan een nieuwe file maken, waarden er in zetten en dan een SaveAs de nieuwe naam.
Alvast bedankt.
Code:
Sub aaaSaveDocument()
Set oTable = ActiveDocument.Tables(15)
strString = oTable.Rows.Item(1).Cells(1).Range
myFileName = Left(strString, Len(strString) - 2)
myPath = ActiveDocument.FullName
FolderPath = Left(myPath, InStrRev(myPath, "\"))
OldName = Right(myPath, Len(myPath) - InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
NewName = FolderPath & myFileName & SaveExt
r = 1
'De waarde uit de eerste Cell van de WORDtable wordt gelezen
strString = oTable.Rows.Item(1).Cells(1).Range
'De check of de cell leeg is
If Strings.Len(strString) > 2 Then
strString = Left(strString, Len(strString) - 1)
strUserID = Right(Environ("userprofile"), Len(Environ("userprofile")) - InStrRev(Environ("userprofile"), "\"))
ExcelName = "SBV-" & strUserID & ".xlsx"
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
File = FolderPath & ExcelName
'Als de Excel file al bestaat dan die openen
If FileFolderExists(File) Then
Set wb = xlsApp.Workbooks.Open(File)
Set ws = wb.Sheets(1)
curRowValue = wb.Worksheets(1).Range("A" & r).Value
Do While curRowValue <> ""
curRowValue = wb.Worksheets(1).Range("A" & r).Value
If curRowValue <> "" Then r = r + 1
Loop
wb.Worksheets(1).Range("A" & r).Value = strString
dtmDate = Now
wb.Worksheets(1).Range("B" & r).Value = dtmDate
wb.Worksheets(1).Range("C" & r).Value = strUserID
strUserName = Application.UserName
wb.Worksheets(1).Range("D" & r).Value = strUserName
wb.Close savechanges:=True
'Als de Excel file nog NIET bestaat dan een nieuwe openen
Else
Set wb = xlsApp.Workbooks.Add
Set ws = wb.Sheets(1)
curRowValue = wb.Worksheets(1).Range("A" & r).Value
Do While curRowValue <> ""
curRowValue = wb.Worksheets(1).Range("A" & r).Value
If curRowValue <> "" Then r = r + 1
Loop
wb.Worksheets(1).Range("A" & r).Value = strString
dtmDate = Now
wb.Worksheets(1).Range("B" & r).Value = dtmDate
wb.Worksheets(1).Range("C" & r).Value = strUserID
strUserName = Application.UserName
wb.Worksheets(1).Range("D" & r).Value = strUserName
xlsApp.SaveAs FileName:=File
End If
End If
xlsApp.Quit
Set wb = Nothing
Set xlsApp = Nothing
End Sub
