Option Explicit
Private Sub cmdExport_Click()
Dim lngLastRow As Long, lngLastCol As Long, i As Long, j As Long
Dim varOutput() As String
Dim strLine As String, strOutput As String, strFile As String, strFilePath
Dim intFile As Integer
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
'\\ Get Grid Data
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
lngLastCol = Cells.Find("*", [A1], xlFormulas, xlPart, xlByColumns, xlPrevious).Column
'\\ To load output we use Array which we'll use in creating output files
ReDim varOutput(lngLastRow - 1)
'\\ Loop through data grid
For i = 1 To lngLastRow
strLine = ""
For j = 1 To lngLastCol
If Len(Cells(i, j).Value) <> 0 Then
If Len(strLine) = 0 Then
strLine = Cells(i, j).Value
Else
strLine = strLine & vbTab & Cells(i, j).Value
End If
End If
varOutput(i - 1) = strLine
Next j
Next i
'\\ Combine output
strOutput = Join(varOutput, vbCrLf)
'\\ Get FileName and write output to it
strFile = Split(ThisWorkbook.Name, ".")(0)
strFilePath = ThisWorkbook.Path & Application.PathSeparator & strFile & ".txt"
intFile = FreeFile
Open strFilePath For Output As #intFile
Print #intFile, strOutput
Close #intFile
'\\ Open the file created in notepad
Shell "notepad.exe " & Chr(34) & strFilePath & Chr(34), vbNormalFocus
'\\ Start word and create new document to paste data
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
End If
'\\ Create New document
On Error Resume Next
strFilePath = ThisWorkbook.Path & Application.PathSeparator & strFile & ".docx"
Set wdDoc = wdApp.Documents.Open(strFilePath)
On Error GoTo 0
If Not wdDoc Is Nothing Then
wdDoc.Range.Delete
Else
Set wdDoc = wdApp.Documents.Add
End If
'\\ Save data to document
wdDoc.Range.Text = strOutput
wdDoc.SaveAs2 strFilePath
End Sub
