P
prkhan56
Hello All,
I am using Office 2003/Windows XP.
I have copied this macro from the newsgroup which transfers all Tables
from the Active Document to Excel.
There is a column with the Heading “Date” in the Word Table.
When the macro runs and transfes data to excel it changes some dates
to mm/dd/yyyy and some to dd/mm/yyyy.
I wish that the dates in the column with Heading “Date” should not
change when it is transferred to Excel. My requirement is dd/mm/yyyy.
Secondly when the data is transferred the first row of each Table
should be in Bold Format.
Can this be done? Any help would be greatly appreciated.
Thanks
Rashid Khan
Follwing is the macro:
Option Explicit
Sub export()
'excel variables
Dim aex As Excel.Application
Dim wbex As Excel.Workbook
Dim shex As Excel.Worksheet
Dim raex As Excel.Range
Set aex = New Excel.Application
Set wbex = aex.Workbooks.Add
Set shex = wbex.Worksheets.Add
wbex.Worksheets("Sheet1").Delete
wbex.Worksheets("Sheet2").Delete
wbex.Worksheets("Sheet3").Delete
shex.Unprotect
'word variables
Dim t As Word.Table
'word properties
Dim nRows As Integer
Dim ncols As Integer
Dim cRow As Integer, cCol As Integer
Dim scont As String
shex.Name = "Extracted"
For Each t In ActiveDocument.Tables
nRows = t.Rows.Count
ncols = t.Columns.Count
Dim neRows As Integer, neCols As Integer 'excel
Set shex = wbex.Worksheets(1)
DetermineUsedRange wbex.Worksheets("Extracted"), raex
If raex Is Nothing Then
neRows = 0
neCols = 0
Else
neRows = raex.Rows.Count + 1
neCols = raex.Columns.Count
End If
For cRow = 1 To nRows
For cCol = 1 To ncols
scont = Trim(CStr(t.Cell(cRow, cCol).Range.Text))
shex.Cells(neRows + cRow, cCol) = Left(scont,
Len(scont) - 2)
'shex.Cells(cRow, cCol).Formula = Left (scont,
Len(scont) - 2)
Next cCol
Next cRow
Next t
wbex.SaveAs "c:\newfile.xls"
wbex.Close
End Sub
Sub DetermineUsedRange(ByRef xs As Excel.Worksheet, ByRef theRng As
Excel.Range)
Dim nFirstRow As Integer, nFirstCol As Integer, _
nlastrow As Integer, nlastcol As Integer
On Error GoTo handleError
nFirstRow = xs.Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByRows).Row
nFirstCol = xs.Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByColumns).Column
nlastrow = xs.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
nlastcol = xs.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
Set theRng = xs.Range(xs.Cells(nFirstRow, nFirstCol), _
xs.Cells(nlastrow, nlastcol))
Exit Sub
handleError:
End Sub
I am using Office 2003/Windows XP.
I have copied this macro from the newsgroup which transfers all Tables
from the Active Document to Excel.
There is a column with the Heading “Date” in the Word Table.
When the macro runs and transfes data to excel it changes some dates
to mm/dd/yyyy and some to dd/mm/yyyy.
I wish that the dates in the column with Heading “Date” should not
change when it is transferred to Excel. My requirement is dd/mm/yyyy.
Secondly when the data is transferred the first row of each Table
should be in Bold Format.
Can this be done? Any help would be greatly appreciated.
Thanks
Rashid Khan
Follwing is the macro:
Option Explicit
Sub export()
'excel variables
Dim aex As Excel.Application
Dim wbex As Excel.Workbook
Dim shex As Excel.Worksheet
Dim raex As Excel.Range
Set aex = New Excel.Application
Set wbex = aex.Workbooks.Add
Set shex = wbex.Worksheets.Add
wbex.Worksheets("Sheet1").Delete
wbex.Worksheets("Sheet2").Delete
wbex.Worksheets("Sheet3").Delete
shex.Unprotect
'word variables
Dim t As Word.Table
'word properties
Dim nRows As Integer
Dim ncols As Integer
Dim cRow As Integer, cCol As Integer
Dim scont As String
shex.Name = "Extracted"
For Each t In ActiveDocument.Tables
nRows = t.Rows.Count
ncols = t.Columns.Count
Dim neRows As Integer, neCols As Integer 'excel
Set shex = wbex.Worksheets(1)
DetermineUsedRange wbex.Worksheets("Extracted"), raex
If raex Is Nothing Then
neRows = 0
neCols = 0
Else
neRows = raex.Rows.Count + 1
neCols = raex.Columns.Count
End If
For cRow = 1 To nRows
For cCol = 1 To ncols
scont = Trim(CStr(t.Cell(cRow, cCol).Range.Text))
shex.Cells(neRows + cRow, cCol) = Left(scont,
Len(scont) - 2)
'shex.Cells(cRow, cCol).Formula = Left (scont,
Len(scont) - 2)
Next cCol
Next cRow
Next t
wbex.SaveAs "c:\newfile.xls"
wbex.Close
End Sub
Sub DetermineUsedRange(ByRef xs As Excel.Worksheet, ByRef theRng As
Excel.Range)
Dim nFirstRow As Integer, nFirstCol As Integer, _
nlastrow As Integer, nlastcol As Integer
On Error GoTo handleError
nFirstRow = xs.Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByRows).Row
nFirstCol = xs.Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByColumns).Column
nlastrow = xs.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
nlastcol = xs.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
Set theRng = xs.Range(xs.Cells(nFirstRow, nFirstCol), _
xs.Cells(nlastrow, nlastcol))
Exit Sub
handleError:
End Sub