Gantt Chart in Excel

July 8, 2013, 8:42 am

≫ Next: Show Country Flags as Markers on X Y Chart

≪ Previous: India Heat Map on Excel

Download and try these Templates

1 Gantt Chart Using Stacked Bar Chart

Download the working file here https://www.box.com/s/pwj2rq73zg0f8bg8tcke

Steps to use :

Download the template
Read the instructions on "Config Tab" to update it as per your requirement

2 Gantt Chart Using Formula's and Conditional Formatting

Download the working file here https://www.box.com/s/5dg4dusl4lyzf5uhnhqs

Steps to use :

Download the template
Read the instructions on "Config Tab" to update it as per your requirement

↧

Show Country Flags as Markers on X Y Chart

August 25, 2013, 3:43 am

≫ Next: Format Line Chart's Markers and Line colors Using VBA

≪ Previous: Gantt Chart in Excel

If you want to display the country flags as markers on X Y Scatter Chart. Snapshot below:

Steps
1 Download the country flags and save them in a folder
2 Make sure you name the flags as labels or series name
3 Run below macro

Sub custom_markers()
Dim srs As Series
Dim cht As Chart
Dim mapfolder As String

' make sure you save the maps with series name
mapfolder = "C:\Users\admin\Desktop\Flags\"' folder in which i saved all the maps

' change chart name here
Set cht = Sheets("Sheet1").ChartObjects("Chart 1").Chart

' download the maps or shapes and save them in a folder
' I have downloaded maps from this site : http://www.free-country-flags.com/flag_pack.php?id=1

'run a loop to import flags to markes and display them on charts

For Each srs In cht.SeriesCollection
srs.MarkerStyle = xlMarkerStylePicture
srs.Format.Fill.UserPicture (mapfolder & srs.Name & ".png")
srs.Format.Line.Visible = msoFalse
srs.MarkerForegroundColorIndex = xlColorIndexNone
Next srs

End Sub

Download working File https://app.box.com/s/ulyhg0etinlsqlz88uyr

↧

Format Line Chart's Markers and Line colors Using VBA

September 15, 2013, 12:11 am

≫ Next: Open a delimit notepad file in Excel

≪ Previous: Show Country Flags as Markers on X Y Chart

Change the style of marker and color using VBA. Snapshot below -

Download working File here

All you need to create a table with series name mentioned in cells and add colors to cells next to it Snapshot below -

Download the sample file to know more.

Macro used to format the chart -

Sub format_chart()
Dim srs As Series
Dim cht As Chart

Set cht = Sheets("Sheet1").ChartObjects("Chart 1").Chart

For Each srs In cht.SeriesCollection ' remove exisiting series
'change marker color
srs.MarkerStyle = xlMarkerStyleCircle ' chnage style of marker
srs.MarkerSize = 10 ' size of marker
srs.MarkerBackgroundColorIndex = xlColorIndexNone ' fill color to none
' add circle color
srs.MarkerForegroundColor = Range("f"& Application.WorksheetFunction.Match(srs.Name, Sheets("Sheet1").Range("a:a"), 0)).Interior.Color
srs.Format.Line.Weight = 2 ' width of circle
srs.Format.Line.DashStyle = xlContinuous
' change line color
srs.Border.Color = Range("g"& Application.WorksheetFunction.Match(srs.Name, Sheets("Sheet1").Range("a:a"), 0)).Interior.Color
srs.Border.Weight = 2
srs.Border.LineStyle = xlDash
Next srs

End Sub

↧

Open a delimit notepad file in Excel

November 9, 2013, 9:30 am

≫ Next: Move List-box Items up & Down

≪ Previous: Format Line Chart's Markers and Line colors Using VBA

Macro to open a delimit notepad file in Excel

Sub delimit_txt_file()

Dim fNameAndPath As String

fNameAndPath = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt", Title:="Select File To Open")

Workbooks.OpenText Filename:=fNameAndPath, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="!"' choose ur delimit type here

End Sub

↧

Move List-box Items up & Down

November 22, 2013, 11:15 pm

≫ Next: Loop through all outlook emails saved on your desktop and extract the information

≪ Previous: Open a delimit notepad file in Excel

To move list-box item up and down . Try below code

To move Up
Private Sub CMD_UP_Click()
If Me.lst_selectedfields.ListCount = 0 Then Exit Sub
If Me.lst_selectedfields.ListIndex = 0 Then Exit Sub

Dim i As Long, j As Long, valtoadd As String, bl As Boolean
bl = False
For i = 0 To Me.lst_selectedfields.ListCount - 1
If Me.lst_selectedfields.Selected(i) = True Then
valtoadd = Me.lst_selectedfields.Column(0, i)
Me.lst_selectedfields.RemoveItem (i)
bl = True
j = i - 1
End If
Next
If bl = False Then Exit Sub
Me.lst_selectedfields.AddItem valtoadd, j
Me.lst_selectedfields.ListIndex = j
End Sub

To move Down

Private Sub CMD_DOWN_Click()

If Me.lst_selectedfields.ListCount = 0 Then Exit Sub

If Me.lst_selectedfields.ListIndex = Me.lst_selectedfields.ListCount - 1 Then Exit Sub

Dim i As Long, j As Long, valtoadd As String, bl As Boolean

bl = False

For i = 0 To Me.lst_selectedfields.ListCount - 1

If Me.lst_selectedfields.Selected(i) = True Then

valtoadd = Me.lst_selectedfields.Column(0, i)

Me.lst_selectedfields.RemoveItem (i)

bl = True

j = i + 1

End If

If bl = False Then Exit Sub

Me.lst_selectedfields.AddItem valtoadd, j

Me.lst_selectedfields.ListIndex = j

End Sub

Download the working file and use it

↧

Loop through all outlook emails saved on your desktop and extract the information

February 8, 2014, 12:38 am

≫ Next: Format bubble chart using VBA

≪ Previous: Move List-box Items up & Down

If you want to run a loop through all outlook mails you have stored on your local desktop. Try this code-

'Change folder path
Public Const fldname As String = "C:\Documents and Settings\Ashish Koul\Desktop\saved_mgs\"
    Sub loop_saved_emails()
        Dim MyObj As Object, MySource As Object, file As Variant
        file = Dir(fldname)
        While (file <> "")
            If InStr(file, ".msg") > 0 Then
            Call check_details(file)
            End If
            file = Dir
        Wend
    End Sub

Sub check_details(flnm As Variant)
        Dim OutApp As Object
        Dim OutMail As Object

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.Session.OpenSharedItem(fldname & flnm)
        With OutMail
            MsgBox .Subject
            MsgBox .attachments.Count
            MsgBox .SenderName
            MsgBox .ReceivedTime
            MsgBox .body
        End With


        Set OutMail = Nothing
        Set OutApp = Nothing
    End Sub

Download Working File

↧

Format bubble chart using VBA

February 8, 2014, 1:40 am

≫ Next: Format X Y Chart using VBA

≪ Previous: Loop through all outlook emails saved on your desktop and extract the information

Change the style and color of bubbles using VBA. Snapshot below -

All you need to create a table with series name mentioned in cells and add color to cells next to it Snapshot below -

Macro to format chart -

Sub format_chart()
Dim srs As Series
Dim cht As Chart

Set cht = Sheets("Sheet1").ChartObjects("Chart 1").Chart

    For Each srs In cht.SeriesCollection
        'change marker color
        ' change border
        srs.Border.Color = Range("e"& Application.WorksheetFunction.Match(srs.Name, Sheets("Sheet1").Range("a:a"), 0)).Interior.Color
        srs.Border.Weight = 3
        srs.Border.LineStyle = xlDot ' change style here
        'srs.Format.Fill.BackColor.RGB = RGB(255, 153, 153)
        srs.Format.Fill.Visible = msoFalse
    Next srs

End Sub

Download working File

↧

Format X Y Chart using VBA

February 8, 2014, 2:04 am

≫ Next: Loop through all List-Boxes or Combo-boxes on userform

≪ Previous: Format bubble chart using VBA

Change the style and color of markers using VBA. Snapshot below -

All you need is to create a table with series name mentioned in cells and add color and marker style to cells next to it Snapshot below -

Macro to format chart -

Sub custom_markers()
Dim srs As Series
Dim cht As Chart

Set cht = Sheets("Sheet1").ChartObjects("Chart 1").Chart

    For Each srs In cht.SeriesCollection ' remove exisiting series
        'change marker color
        Select Case Range("e"& Application.WorksheetFunction.Match(srs.Name, Sheets("Sheet1").Range("a:a"), 0))
            Case "Square"
                srs.MarkerStyle = xlMarkerStyleSquare
            Case "Circle"
                srs.MarkerStyle = xlMarkerStyleCircle
            Case "Triangle"
                srs.MarkerStyle = xlMarkerStyleTriangle
        End Select

        srs.MarkerSize = 10
        srs.MarkerBackgroundColorIndex = xlColorIndexNone
        srs.MarkerForegroundColor = Range("d"& Application.WorksheetFunction.Match(srs.Name, Sheets("Sheet1").Range("a:a"), 0)).Interior.Color
        srs.Format.Line.Weight = 2
        srs.Format.Line.DashStyle = xlContinuous
    Next srs

End Sub

Download Working File

↧

Loop through all List-Boxes or Combo-boxes on userform

February 22, 2014, 6:44 am

≫ Next: Compare two worksheet ranges from same or different workbook and identify the difference

≪ Previous: Format X Y Chart using VBA

Macro to loop through all combo-boxes and list-boxes on user-form and set the row-source

Sub loop_listbox_userform()
    Dim cnt As Control
    ' change userform name
    For Each cnt In UserForm1.Controls ' loop through all controls on userform
        If TypeName(cnt) = "ListBox" Then ' Set rowsource for listbox
           cnt.RowSource = "Sheet1!a1:a7"
        ElseIf TypeName(cnt) = "ComboBox" Then 'Set rowsource for combobox
           cnt.RowSource = "Sheet1!b1:b7"
        End If

    Next
    UserForm1.Show
End Sub

↧

Compare two worksheet ranges from same or different workbook and identify the difference

April 19, 2014, 10:36 am

≫ Next: Save Specific Worksheet as new workbook

≪ Previous: Loop through all List-Boxes or Combo-boxes on userform

Macro to compare two worksheet ranges in same or different workbook and identify cell address which does not match-

Sub compare_range()

Dim basewkb As Workbook
Dim comparetowkb As Workbook
Dim outputwkb As Workbook


Dim basewks As Worksheet
Dim comparetowks As Worksheet

Dim baserng As Range
Dim comparetorng As Range

Dim rowcount As Long
Dim columncount As Long
Dim strow As Long

'Set basewkb = ThisWorkbook 'use in case of same workbook
Set basewkb = Workbooks.Open("C:\Documents and Settings\Ashish Koul\Desktop\New Folder\sample1.xlsx") 'use in case of external workbook

'Set comparetowkb = ThisWorkbook 'use in case of same workbook
Set comparetowkb = Workbooks.Open("C:\Documents and Settings\Ashish Koul\Desktop\New Folder\sample2.xlsx") 'use in case of external workbook

Set basewks = basewkb.Sheets("Sheet1") ' set worksheet
Set comparetowks = comparetowkb.Sheets("Sheet1") 'set worksheet


Set baserng = basewks.Range("a1:b6")
Set comparetorng = comparetowks.Range("a1:b6")

If baserng.Columns.Count <> comparetorng.Columns.Count Or baserng.Rows.Count <> comparetorng.Rows.Count Then
GoTo releaseobject:
Else
Set outputwkb = Workbooks.Add
outputwkb.Sheets(1).Cells(1, 1).Value = "Base worksheet Name"
outputwkb.Sheets(1).Cells(1, 2).Value = "Cell Address (Base worksheet)"
outputwkb.Sheets(1).Cells(1, 3).Value = "Cell Value(Base worksheet)"
outputwkb.Sheets(1).Cells(1, 4).Value = "CompareTo worksheet Name"
outputwkb.Sheets(1).Cells(1, 5).Value = "Cell Address (CompareTo worksheet)"
outputwkb.Sheets(1).Cells(1, 6).Value = "Cell Value (CompareTo worksheet)"
strow = 2
For rowcount = 1 To baserng.Rows.Count
For columncount = 1 To baserng.Columns.Count
If baserng.Cells(rowcount, columncount).Value <> comparetorng.Cells(rowcount, columncount).Value Then
outputwkb.Sheets(1).Cells(strow, 1).Value = basewks.Name
outputwkb.Sheets(1).Cells(strow, 2).Value = baserng.Cells(rowcount, columncount).Address
outputwkb.Sheets(1).Cells(strow, 3).Value = baserng.Cells(rowcount, columncount).Value
outputwkb.Sheets(1).Cells(strow, 4).Value = comparetowks.Name
outputwkb.Sheets(1).Cells(strow, 5).Value = comparetorng.Cells(rowcount, columncount).Address
outputwkb.Sheets(1).Cells(strow, 6).Value = comparetorng.Cells(rowcount, columncount).Value
strow = strow + 1
End If
Next
Next
outputwkb.Sheets(1).UsedRange.EntireColumn.AutoFit
End If

releaseobject:
basewkb.Close ' close in case of external workbook
comparetowkb.Close 'close in case of external workbook
Set baserng = Nothing
Set comparetorng = Nothing
Set basewks = Nothing
Set comparetowks = Nothing
Set basewkb = Nothing
Set comparetowkb = Nothing

End Sub

Download Working File

↧

Save Specific Worksheet as new workbook

April 19, 2014, 10:41 am

≫ Next: Display External Links if any in the workbook

≪ Previous: Compare two worksheet ranges from same or different workbook and identify the difference

Macro to save specific worksheet as a new workbook-

Sub save_specific_worksheets_as_new_workbook()
Dim wk As Worksheet
Dim shtnames()
shtnames = Array("Sheet1", "Sheet2", "PPT") ' ADD SHEET NAMES

' loop through each worksheet
For Each wk In ThisWorkbook.Worksheets
For i = LBound(shtnames) To UBound(shtnames)
If wk.Name = shtnames(i) Then
' save it in new workbook
wk.Copy
' save the new workbook with sheet name
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\"& wk.Name & VBA.Format(VBA.Now, "_ddmmyyyy_hhmmss") & ".xlsx"
' close the newly created workbook
ActiveWorkbook.Close
Exit For
End If
Next
Next

End Sub

↧

Display External Links if any in the workbook

April 19, 2014, 10:48 am

≫ Next: Break External Workbook Links

≪ Previous: Save Specific Worksheet as new workbook

Macro to pop-up the full path of external workbooks used in the formula's

Sub external_lins()
Dim extlinks
Dim j As Long
extlinks = ThisWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(extlinks) Then
For j = LBound(extlinks) To UBound(extlinks)
MsgBox extlinks(j)
Next
End If

End Sub

↧

Break External Workbook Links

April 19, 2014, 12:13 pm

≫ Next: Find cells linked to external workbook

≪ Previous: Display External Links if any in the workbook

Macro to break External Workbook Links -

Sub break_external_links()
Dim extlinks
Dim j As Long
extlinks = ThisWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(extlinks) Then
For j = LBound(extlinks) To UBound(extlinks)
ThisWorkbook.BreakLink Name:=extlinks(j), Type:=xlLinkTypeExcelLinks
Next
End If

End Sub

↧

Find cells linked to external workbook

April 19, 2014, 12:24 pm

≫ Next: Print All Formula’s used in a workbook

≪ Previous: Break External Workbook Links

Macro to find all cells which are linked to any external workbook-

Sub find_cells_linked_to_external_workbooks()
Dim extlinks
Dim j As Long, k As Long
Dim wkb As Workbook
Dim rng As Range, cl As Range
Dim links1 As String
Dim wk As Worksheet
Set wkb = Workbooks.Add
wkb.Sheets(1).Range("a1").Value = "Sheet Name"
wkb.Sheets(1).Range("b1").Value = "Cell Address"
wkb.Sheets(1).Range("c1").Value = "Formula"
wkb.Sheets(1).Range("d1").Value = "External Link"
k = 2
extlinks = ThisWorkbook.LinkSources(xlExcelLinks)

For Each wk In ThisWorkbook.Sheets
On Error Resume Next
Set rng = wk.UsedRange.SpecialCells(xlCellTypeFormulas)

If Not rng Is Nothing Then
For j = LBound(extlinks) To UBound(extlinks)
links1 = Left(extlinks(j), InStrRev(extlinks(j), "\")) & "["& Right(extlinks(j), Len(extlinks(j)) - InStrRev(extlinks(j), "\"))
For Each cl In rng
If InStr(""& cl.Formula, links1) > 0 Then
wkb.Sheets(1).Range("a"& k).Value = wk.Name
wkb.Sheets(1).Range("b"& k).Value = cl.Address
wkb.Sheets(1).Range("c"& k).Value = "'"& cl.Formula
wkb.Sheets(1).Range("d"& k).Value = extlinks(j)
k = k + 1
End If
Next
Next
End If
Set rng = Nothing
Next

End Sub

↧

Print All Formula’s used in a workbook

April 19, 2014, 9:14 pm

≫ Next: UDF to count cells with format Bold or Italics or Strike-through or Underline

≪ Previous: Find cells linked to external workbook

Macro to print all formula's used in a workbook. Snapshot below -

Code -

Sub all_formulas()
Dim extlinks
Dim j As Long, k As Long
Dim wkb As Workbook
Dim rng As Range, cl As Range
Dim links1 As String
Dim wk As Worksheet
Set wkb = Workbooks.Add
wkb.Sheets(1).Range("a1").Value = "Sheet Name"
wkb.Sheets(1).Range("b1").Value = "Cell Address"
wkb.Sheets(1).Range("c1").Value = "Formula"
wkb.Sheets(1).Range("d1").Value = "Value"
wkb.Sheets(1).Range("e1").Value = "External Link"
wkb.Sheets(1).Range("f1").Value = "Formula length"
k = 2
extlinks = ThisWorkbook.LinkSources(xlExcelLinks)

For Each wk In ThisWorkbook.Sheets
On Error Resume Next
Set rng = wk.UsedRange.SpecialCells(xlCellTypeFormulas)

If Not rng Is Nothing Then
For Each cl In rng
wkb.Sheets(1).Range("a"& k).Value = wk.Name
wkb.Sheets(1).Range("b"& k).Value = cl.Address
wkb.Sheets(1).Range("c"& k).Value = "'"& cl.Formula
wkb.Sheets(1).Range("d"& k).Value = cl.Text
For j = LBound(extlinks) To UBound(extlinks)
links1 = Left(extlinks(j), InStrRev(extlinks(j), "\")) & "["& Right(extlinks(j), Len(extlinks(j)) - InStrRev(extlinks(j), "\"))
If InStr(""& cl.Formula, links1) > 0 Then
wkb.Sheets(1).Range("e"& k).Value = extlinks(j)
Exit For
End If
Next
wkb.Sheets(1).Range("f"& k).Value = Len(cl.Formula)
k = k + 1
Next

End If
Set rng = Nothing
Next
End Sub

↧

UDF to count cells with format Bold or Italics or Strike-through or Underline

April 19, 2014, 11:53 pm

≫ Next: Search a text in excel workbooks and if found return the full path of workbooks

≪ Previous: Print All Formula’s used in a workbook

User defined function to count the formatted cells in a range. Snapshot below -

Function count_values(datarng As Range, formatconditon As String)
'datarng is range to look into
'formatconditon use B to check bold , i to check italics
'st to check strikethrough, u to check underline
Dim ct As Double
Dim cl As Range
ct = 0
For Each cl In datarng
Select Case UCase(formatconditon)
Case "B"
If cl.Font.Bold = True Then ct = ct + 1
Case "I"
If cl.Font.Italic = True Then ct = ct + 1
Case "ST"
If cl.Font.Strikethrough = True Then ct = ct + 1
Case "U"
If cl.Font.Underline = 2 Or cl.Font.Underline = 4 Or cl.Font.Underline = 5 Then ct = ct + 1
End Select
Next

count_values = ct

End Function

How to Use : =count_values(range _to_check ,"b")

use b for bold, i for italics, st for strikethrough and u for underline

Download working File

↧

Search a text in excel workbooks and if found return the full path of workbooks

April 20, 2014, 3:05 am

≫ Next: Search a text in word documents and if found return the full path of document

≪ Previous: UDF to count cells with format Bold or Italics or Strike-through or Underline

Macro to search a text in all excel workbooks saved in a folder and if text is found return the full path of workbooks

Sub search_text_in_excel_files()
'search a text in excel workbooks saved in a folder and return the full file path of all workbooks which contains the text
Dim filenm As String, folderpath As String
Dim wordtocheck As String
folderpath = "C:\Users\ADMIN\Desktop\sample files\"' change folder here
wordtocheck = "ashish"' change text to found here
filenm = Dir(folderpath)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
While (filenm <> "")
If InStr(filenm, ".xls") > 0 Then ' open only excel workbooks
' if found display full path in message box
If check_in_file(folderpath & filenm, wordtocheck) = True Then MsgBox folderpath & filenm
End If
filenm = Dir
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Function check_in_file(filname As String, word_to_check As String) As Boolean
Dim wkb As Workbook
Dim foundcell As Range
Dim wks As Worksheet
Set wkb = Workbooks.Open(filname)

For Each wks In wkb.Worksheets
Set foundcell = wks.Cells.Find(What:="*"& word_to_check & "*", After:=wks.Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not foundcell Is Nothing Then
check_in_file = True
wkb.Close , False
Exit Function
End If
Next
check_in_file = False
wkb.Close , False

End Function

Download File

↧

Search a text in word documents and if found return the full path of document

April 20, 2014, 4:25 am

≫ Next: Copy all tables from a word document and paste them in a separate new workbook

≪ Previous: Search a text in excel workbooks and if found return the full path of workbooks

Macro to search a text in the word documents saved in a folder and return the full document path of all documents which contains the text -

Sub search_text_in_word_docs()
'search a text in the word documents saved in a folder and return the full document path of all documents which contains the text
Dim filenm As String, folderpath As String
Dim wordtocheck As String
folderpath = "C:\Users\ADMIN\Desktop\sample files\"' change folder here
wordtocheck = "abc"' change text to search here
filenm = Dir(folderpath)
While (filenm <> "")
If InStr(filenm, ".doc") > 0 Then ' check word document
If check_in_file(folderpath & filenm, wordtocheck) = True Then MsgBox folderpath & filenm
End If
filenm = Dir
Wend
End Sub

Function check_in_file(filname As String, word_to_check As String) As Boolean
Dim objWord As Object
Dim objdoc As Object
Dim content1 As String

Set objWord = CreateObject("Word.Application")
Set objdoc = objWord.Documents.Open(filname)

content1 = ""& objdoc.Content.Text

If InStr(UCase(content1), UCase(word_to_check)) <> 0 Then
check_in_file = True
Else
check_in_file = False
End If
objdoc.Close
Set objdoc = Nothing
Set objWord = Nothing

End Function

↧

Copy all tables from a word document and paste them in a separate new workbook

April 20, 2014, 4:51 am

≫ Next: Copy all tables from word document to separate worksheets

≪ Previous: Search a text in word documents and if found return the full path of document

Macro to copy all tables from a document and paste them in a separate workbook-

Sub import_word_tables_seperate_workbook()
Dim objWord As Object
Dim objdoc As Object
Dim i As Integer
Dim wkb As Workbook
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objdoc = objWord.Documents.Open("C:\Users\ADMIN\Desktop\sample files\sample.docx") ' open the document

For i = 1 To objdoc.Tables.Count
objdoc.Tables(i).Range.Copy ' copy table
Set wkb = Workbooks.Add ' add new workbook
Range("a1").Select
ActiveSheet.Paste ' paste table
wkb.SaveAs "C:\Users\ADMIN\Desktop\sample files\Table_"& i & ".xlsx"' save workbook with table name
wkb.Close
Set wkb = Nothing
Next

objdoc.Close
objWord.Quit
Set objdoc = Nothing
Set objWord = Nothing

End Sub

↧

Copy all tables from word document to separate worksheets

April 20, 2014, 6:06 am

≫ Next: Export Range to Pipe Delimit Text File

≪ Previous: Copy all tables from a word document and paste them in a separate new workbook

Macro to copy all tables from word document to separate worksheets -

Sub import_word_tables_to_seperate_sheet()
Dim objWord As Object
Dim objdoc As Object
Dim i As Integer
Dim wkb As Workbook
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objdoc = objWord.Documents.Open("C:\Users\ADMIN\Desktop\sample files\sample.docx") ' choose word document

For i = 1 To objdoc.Tables.Count
objdoc.Tables(i).Range.Copy ' copy tables
ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Table_"& i ' add new sheet
Range("a1").Select ' paste table
ActiveSheet.Paste
Next

objdoc.Close
objWord.Quit
Set objdoc = Nothing
Set objWord = Nothing

End Sub

↧