Modifying a Macro - Help Please

[LPS]

A few months ago, someone (I apologise as I cannot remember who) very kindly
gave me some terrific help with an Excel Macro. The macro was designed to
add a new row, in the same positon, to several workbooks simultaneously. The
workbooks getting the new row have their names hard-coded in the macro (see
code below).

Initially my client did not give me all the details of her situation. What
my client really needs is for that macro to add a specific row, not just to
the identified workbooks in the macro, but to all workbooks within a specific
directory. She has hundreds of workbooks spread throughout about 3 dozen (or
more) directories.

Can this mcaro (below) be modified to autoamtically add whatever row number
to ALL workbooks with the directory? We are using Excel 2000 in a Windows
2000 or XP O/S. Any and all help is hugely appreciated. Cheers - LPS.

Existing Macro:

Sub AddRows()
Dim sPath As String, v As Variant
Dim bk As Workbook, i As Long
Dim ans As Variant
Dim rw As Long

ans = Application.InputBox("Enter the row to add", Type:=1)
If ans = False Then Exit Sub
rw = CLng(ans)
sPath = "H:\training\user requests\2007\helen tsang\Macro Test\"
v = Array("1424511.xls", "1424611.xls", "1424411.xls", _
"141461.xls", "141451.xls", "141251.xls", _
"tu0336001.xls", "tu033000w.xls")
For i = LBound(v) To UBound(v)
Set bk = Workbooks.Open(Filename:=sPath & v(i))
bk.Worksheets(1).Rows(rw).Insert
Next
End Sub

 

[barnabel]

you could try something like:
Sub AddRows()
Dim sPath As String, v As Variant
Dim bk As Workbook, i As Long
Dim ans As Variant
Dim rw As Long

ans = Application.InputBox("Enter the row to add", Type:=1)
If ans = False Then Exit Sub
rw = CLng(ans)
sPath = "H:\training\user requests\2007\helen tsang\Macro Test\"
With Application.FileSearch
.NewSearch
.LookIn = sPath
.Filename = "*.xls"
.MatchTextExactly = False
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If (.Execute > 0) Then
For i = 1 To .FoundFiles.Count
Set bk = Workbooks.Open(Filename:=sPath & .FoundFiles(i))
bk.Worksheets(1).Rows(rw).Insert
bk.Close ' probably don't want them all open
Next
End If
End With
End Sub

 

[Bob Phillips]

Sub AddRows()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim sPath As String, v As Variant
Dim bk As Workbook, i As Long
Dim ans As Variant
Dim rw As Long

ans = Application.InputBox("Enter the row to add", Type:=1)
If ans = False Then Exit Sub
rw = CLng(ans)

sPath = "C:\test\" '"H:\training\user requests\2007\helen tsang\Macro
Test\"
Set oFSO = CreateObject("Scripting.FileSystemobject")
Set oFolder = oFSO.GetFolder(sPath)

For Each oFile In oFolder.Files
If oFile.Type Like "*Excel*" Then
Set bk = Workbooks.Open(Filename:=oFile.Path)
bk.Worksheets(1).Rows(rw).Insert
bk.Save
bk.Close
End If
Next file

Set bk = Nothing
Set Folder = Nothing
Set oFSO = Nothing

End Sub


--
---
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[JLatham]

If you don't have the FileSearch available (gone in 2007), or if scripting is
not available, you can use the 'old fashioned' way by simply selecting the
folder and working through the list of .xls files in it using Dir$()

Sub AddRowToAllFiles()
Dim fNames() As String
Dim anyFile As String

Dim sPath As String
Dim bk As Workbook, i As Long
Dim ans As Variant
Dim rw As Long

ans = Application.InputBox("Enter the row to add", Type:=1)
If ans = False Then Exit Sub
rw = CLng(ans)
sPath = GetFolder()
If sPath = Application.PathSeparator Then
MsgBox "No folder selected. Exiting.", vbOKOnly, _
"Cannot Continue"
Exit Sub
End If
'initialize array fNames()
ReDim fNames(1 To 1)
'with path determined, get list of .xls file in it
anyFile = Dir$(sPath & "*.xls") ' seed entry
Do While anyFile <> ""
If UBound(fNames) <> "" Then
ReDim Preserve fNames(1 To UBound(fNames) + 1)
End If
fNames(UBound(fNames)) = anyFile
anyFile = Dir$ ' get next .xls filename
Loop
'test if any files found
If fNames(UBound(fNames)) = "" Then
MsgBox "No .xls files found in path" & vbCrLf & sPath, _
vbOKOnly, "Exiting"
Exit Sub
End If

'v no longer used, array fNames() has data
For i = LBound(fNames) To UBound(fNames)
Set bk = Workbooks.Open(Filename:=sPath & fNames(i))
bk.Worksheets(1).Rows(rw).Insert
Next

End Sub
Private Function GetFolder() As String
'NOTE: returns 1 character string "\" (PathSeparator)
'if the user cancels - test for that on return
'
Dim dlg As FileDialog
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
If dlg.Show = -1 Then
GetFolder = dlg.SelectedItems(1)
End If
If Right(GetFolder, 1) <> Application.PathSeparator Then
GetFolder = GetFolder & Application.PathSeparator
End If
End Function

 

[LPS]

Thank you to both "Barnabel" and "Bob Phillips". I will try both suggestions.

Cheers,

 

[barnabel]

That is frustrating. Why would they take a perfectly useful function out? I
am just starting to convert stuff from Excel 2000 to 2007. Now I am going to
have to deal with things that have always worked not compiling.

 

[Bob Phillips]

It is one of the very few things to worry about.

--
---
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)