I am creating lots of training material and need to transcribe video/audio files to add closed captions. Getting a new software approved takes forever where I work, so I looked at what I had. MS Office.
I ultimately need to create a .vtt file to upload into Articulate360 (create txt file UTF-8 and change the extn). The vtt file needs a specific format with a specific word at the top then a clear line, timestamp (in a certain format), the text on the next line, clear line - repeat timestamp/text/clear line. Here starts my intro to VBA. I can make it work, but I can't make all the working bits work together.
An example working vtt file is below for format:
WEBVTT
00:00:01.100 --> 00:00:06.000
Saving a query is very simple. Navigate to the query icon.
00:00:06.100 --> 00:00:12.000
Then find your query you wish to save. Click on the disc icon.
00:00:12.100 --> 00:00:16.000
Add a name.
00:00:16.100 --> 00:00:19.000
Then click save.
00:00:19.100 --> 00:00:22.000
And that is your query saved.
00:00:22.100 --> 00:00:27.000
If we show the queries again, you can now see my saved query.
As I am new to Macros I did it in steps and edited from recording my actions/using forums. I have tried lots so this is long. I use Word to transcribe and then I add to document with timestamps. It has the following format with some word formatting:
Audio file
transcribed file name as a link
Transcript
00:00:01
Saving a query is very simple. Navigate to the query icon.
00:00:06
Then find your query you wish to save. Click on the disc icon.
00:00:12
Add a name.
00:00:16
Then click save.
00:00:19
And that is your query saved.
00:00:22
If we show the queries again, you can now see my saved query.
I have the following working macros but I am having trouble combining them. This Macro works and runs from Word to remove formatting add the milliseconds portion, arrow and blank lines
Sub CCCWordStep1()
'
CCCWordStep1 Macro
Prep file for excel
' "&chr(10)&"1:Remove Link
' "&chr(10)&"2:Clear all formatting
' "&chr(10)&"3:Append '.100 -->' to the timestamp
' "&chr(10)&"4: Add required blank lines
'
Selection.Range.Hyperlinks(1).Delete
Selection.ClearFormatting
Selection.WholeStory
Selection.ClearFormatting
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^#^#:^#^#:^#^#"
.Replacement.Text = "^p^&.100-->"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Then I have another macro to copy, paste as text in excel, save as xlsx file (I couldn't get it to save as a readable text file so removed that requirement for now), close/quit
Sub CopyWordDocToExcel()
Dim wdApp As Object
Dim wdDoc As Object
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
'Get the running instance of Word and the active document
Set wdApp = GetObject(, "Word.Application")
Set wdDoc = wdApp.ActiveDocument
'Create a new instance of Excel and add a new workbook
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
'Copy the contents of the Word document to the clipboard
wdDoc.Content.Copy
'Paste the contents into the first worksheet of the new Excel workbook
Set xlWs = xlWb.Worksheets(1)
xlWs.Range("A1").PasteSpecial xlPasteValues
'Save and close the Excel workbook
xlWb.SaveAs "C:\VBA\Workbook.xlsx"
xlWb.Close
'Quit Excel and release objects from memory
xlApp.Quit
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
End Sub
I have a macro in Excel that does the other edits I require:
Sub excel1()
Rows(1).EntireRow.Delete
Rows(2).EntireRow.Delete
Range("A1").Select
ActiveCell.Value = "WEBVTT -" & ActiveCell.Value
Range("B3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(COUNTIF(RC[-1],""*-->""),(CONCAT((LEFT(R[3]C[-1], LEN(R[3]C[-1])-7)),""000"")),""""),""01:00:00.000"")"
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("B3").AutoFill Destination:=Range("B3:B" & lastRow)
End Sub
This gives me my excel file in the required format which I then open, manually save as a .prn file (txt file gave some other issues and this way works) and manually change the extn in file explorer, upload to Articulate and it works.
However, if I try to run the code below from Word, I get a file saved, I get the removed rows, the edited A1 cell is only the original value (no WEBVTT - added) and no formula or autofill.(FYI: If I paste the working excel code directly as written above I get no edits at all)
Sub CopyWordDocToExcelEdited()
Dim wdApp As Object
Dim wdDoc As Object
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
'Get the running instance of Word and the active document
Set wdApp = GetObject(, "Word.Application")
Set wdDoc = wdApp.ActiveDocument
'Create a new instance of Excel and add a new workbook
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets(1)
'Copy the contents of the Word document to the clipboard
wdDoc.Content.Copy
'Paste the contents into the first worksheet of the new Excel workbook
xlWs.Range("A1").PasteSpecial xlPasteValues
'make an edit
xlWs.Rows(1).EntireRow.Delete
xlWs.Rows(2).EntireRow.Delete
xlWs.Range("A1").Select
ActiveCell.Value = "WEBVTT -" & ActiveCell.Value
xlWs.Range("B3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(COUNTIF(RC[-1],""*-->""),(CONCAT((LEFT(R[3]C[-1], LEN(R[3]C[-1])-7)),""000"")),""""),""01:00:00.000"")"
Dim lastRow As Long
lastRow = xlWs.Range("A" & Rows.Count).End(xlUp).Row
xlWs.Range("B3").AutoFill Destination:=xlWs.Range("B3:B" & lastRow)
'Save and close the Excel workbook
xlWb.SaveAs "C:\VBA\Workbook.xlsx"
xlWb.Close
'Quit Excel and release objects from memory
xlApp.Quit
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
End Sub
I have these references checked:
The error is 'cos you use "" - replace symbol " in formula body to
&Chr(34)&and all will work