Run macro in files of folder and output in one new book

[pragnesh_50]

Hi i have following macro which run in particlular book.


but i want it to work at all the books of particalur folder.


and want output in one file only

[pre]

Sub showcomments()
'posted by Dave Peterson 2003-05-16
Application.ScreenUpdating = False

Dim commrange As Range
Dim cmt As Comment
Dim curwks As Worksheet
Dim newwks As Worksheet
Dim i As Long
Dim current_row As Integer
Dim current_column As Integer
Dim Comment_Author, Comment_Full, Comment_Entry As String     ' New statement , added on Nov. 14 , 2011
Dim Extra_length As Integer                                   ' New statement , added on Nov. 14 , 2011

Set curwks = ActiveSheet

On Error Resume Next
Set commrange = curwks.Cells _
.SpecialCells(xlCellTypeComments)
On Error GoTo 0

If commrange Is Nothing Then
MsgBox "no comments found"
Exit Sub
End If
Comment_Author = commrange.Comment.Author      ' New statement , added on Nov. 14 , 2011
Extra_length = Len(Comment_Author) + 2         ' New statement , added on Nov. 14 , 2011

Set newwks = Worksheets.Add

newwks.Range("A1:I1").Value = _
Array("Number", "Address", "Author", "Nan", "Ean", "Characteristic Type", "Value Coded", "Value Suggested", "Value Suggested without Author name")

i = 1
For Each cmt In curwks.Comments
With newwks
i = i + 1
On Error Resume Next
.Cells(i, 1).Value = i - 1
.Cells(i, 2).Value = cmt.Parent.Address
.Cells(i, 3).Value = Replace(cmt.Author, Chr(10), " ")
Comment_Full = cmt.Parent.Comment.Text                                  ' New statement , added on Nov. 14 , 2011
Comment_Entry = Right(Comment_Full, Len(Comment_Full) - Extra_length)   ' New statement , added on Nov. 14 , 2011
current_row = cmt.Parent.Row
current_column = cmt.Parent.Column
.Cells(i, 4).Value = cmt.Parent.Offset(0, -current_column + 1).Value
.Cells(i, 5).Value = cmt.Parent.Offset(0, -current_column + 2).Value
.Cells(i, 6).Value = cmt.Parent.Offset(-current_row + 8, 0).Value
.Cells(i, 7).Value = cmt.Parent.Value
.Cells(i, 8).Value = Replace(cmt.Text, Chr(10), " ")
.Cells(i, 9).Value = Comment_Entry                                      ' New statement , added on Nov. 14 , 2011
End With
Next cmt

newwks.Cells.WrapText = False
newwks.Columns.AutoFit

Application.ScreenUpdating = True

End Sub

[/pre]

Could you update it?


Reagrds,

Pragnesh