Solved

Macro built in Excel 2003 to be updated for Excel 2010

Posted on 2014-07-29
1
542 Views
Last Modified: 2014-07-29
Hello,
I have a macro that was developed in Excel 2003 that I now need updated to work in Excel 2010. I have attached the code below that needs to be updated. The main challenges seem to be in relation to the use of ‘Application.Filesearch’ and the use of the count variable in the code.
I’d appreciate if someone can let me know what the updated code should be for this to work in excel 2010.


Sub IndexFiles()
Dim strbook As Workbook
Dim localbook As Workbook
Dim strRange As Range
Dim targetrange As Range
Dim strRange2 As Range
Dim targetrange2 As Range
Dim i As Long
Dim w As Integer

Workbooks.Add
With Application.FileSearch
.LookIn = "C:\Testing\Files"
.FileType = msoFileTypeAllFiles
.SearchSubFolders = False
.Execute

If .Execute() > 0 Then
'MsgBox "Files Exist"
Else
MsgBox "There were no files found."
GoTo macro_end
End If

cnt = Application.FileSearch.FoundFiles.Count
For i = 1 To cnt
 Rng2 = "F" & i
 Rng3 = "C" & i
 Set strbook = ActiveWorkbook
 Set localbook = Workbooks.Open(.FoundFiles(i))
 Set strRange = localbook.Worksheets(1).Range("A3")
 Set targetrange = strbook.Worksheets(1).Range(Rng2)
 strRange.Copy
 targetrange.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
 False, Transpose:=False
 
 Set strRange2 = localbook.Worksheets(1).Range("C2")
 Set targetrange2 = strbook.Worksheets(1).Range(Rng3)
 strRange2.Copy
 targetrange2.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
 False, Transpose:=False
 
 'This code edits the individual Excel files
     With ActiveWindow
        .DisplayGridlines = False
        .DisplayHeadings = False
        .DisplayWorkbookTabs = False
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
 
 Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("B:E").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
   
    ActiveWorkbook.Save
 'End of the file editing
 localbook.Close
               
Rng = "A" & i

Range(Rng).Value = Application.FileSearch.FoundFiles.Item(i)

Next i
End With

macro_end:
'MsgBox "There were no files found."
End Sub
0
Comment
Question by:dm7733
1 Comment
 
LVL 24

Accepted Solution

by:
Steve earned 500 total points
Comment Utility
I have used some code written by Mohammad Basem at MrExcel where he has written a function to perform the task that was done in 2003 from:
http://www.mrexcel.com/forum/excel-questions/643288-excel-2010-visual-basic-applications-replacement-application-filesearch.html

The code added to yours is something like below:
Type FoundFileInfo
    sPath As String
    sName As String
End Type

Function FindFiles(ByVal sPath As String, _
    ByRef recFoundFiles() As FoundFileInfo, _
    ByRef iFilesFound As Integer, _
    Optional ByVal sFileSpec As String = "*.*", _
    Optional ByVal blIncludeSubFolders As Boolean = False) As Boolean

    Dim iCount As Integer           '* Multipurpose counter
    Dim sFileName As String         '* Found file name
    '*
    '* FileSystem objects
    Dim oFileSystem As Object, _
        oParentFolder As Object, _
        oFolder As Object, _
        oFile As Object

    Set oFileSystem = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set oParentFolder = oFileSystem.GetFolder(sPath)
    If oParentFolder Is Nothing Then
        FindFiles = False
        On Error GoTo 0
        Set oParentFolder = Nothing
        Set oFileSystem = Nothing
        Exit Function
    End If
    sPath = IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
    '*
    '* Find files
    sFileName = Dir(sPath & sFileSpec, vbNormal)
    If sFileName <> "" Then
        For Each oFile In oParentFolder.Files
            If LCase(oFile.Name) Like LCase(sFileSpec) Then
                iCount = UBound(recFoundFiles)
                iCount = iCount + 1
                ReDim Preserve recFoundFiles(1 To iCount)
                With recFoundFiles(iCount)
                    .sPath = sPath
                    .sName = oFile.Name
                End With
            End If
        Next oFile
        Set oFile = Nothing         '* Although it is nothing
    End If
    If blIncludeSubFolders Then
        '*
        '* Select next sub-forbers
        For Each oFolder In oParentFolder.SubFolders
            FindFiles oFolder.Path, recFoundFiles, iFilesFound, sFileSpec, blIncludeSubFolders
        Next
    End If
    FindFiles = UBound(recFoundFiles) > 0
    iFilesFound = UBound(recFoundFiles)
    On Error GoTo 0
    '*
    '* Clean-up
    Set oFolder = Nothing           '* Although it is nothing
    Set oParentFolder = Nothing
    Set oFileSystem = Nothing

End Function


Sub IndexFiles()
 Dim strbook As Workbook
 Dim localbook As Workbook
 Dim strRange As Range
 Dim targetrange As Range
 Dim strRange2 As Range
 Dim targetrange2 As Range
 Dim i As Long
 Dim w As Integer

 'Workbooks.Add
 
    Dim iFilesNum As Integer
    Dim iCount As Integer
    Dim recMyFiles() As FoundFileInfo
    Dim blFilesFound As Boolean
    blFilesFound = FindFiles("C:\Testing\Files", recMyFiles, iFilesNum)
    If blFilesFound Then
'        For iCount = 1 To iFilesNum
'            With recMyFiles(iCount)
'                MsgBox "Path:" & vbTab & .sPath & _
'                    vbNewLine & "Name:" & vbTab & .sName, _
'                    vbInformation, "Found Files"
'            End With
'        Next
    Else
        MsgBox "No file(s) found matching the specified file spec.", _
            vbInformation, "File(s) not Found"
        GoTo macro_end
    End If

 cnt = iFilesNum
 
 For i = 1 To cnt
  Rng2 = "F" & i
  Rng3 = "C" & i
  Set strbook = ActiveWorkbook
  Set localbook = Workbooks.Open(recMyFiles(i).sPath & recMyFiles(i).sName)
  Set strRange = localbook.Worksheets(1).Range("A3")
  Set targetrange = strbook.Worksheets(1).Range(Rng2)
  strRange.Copy
  targetrange.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
  False, Transpose:=False
  
  Set strRange2 = localbook.Worksheets(1).Range("C2")
  Set targetrange2 = strbook.Worksheets(1).Range(Rng3)
  strRange2.Copy
  targetrange2.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
  False, Transpose:=False
  
  'This code edits the individual Excel files
     With ActiveWindow
         .DisplayGridlines = False
         .DisplayHeadings = False
         .DisplayWorkbookTabs = False
         .DisplayHorizontalScrollBar = False
         .DisplayVerticalScrollBar = False
     End With
  
  Columns("A:A").Select
     Selection.Insert Shift:=xlToRight
     Columns("B:E").Select
     Selection.Delete Shift:=xlToLeft
     Range("A1").Select
     
    ActiveWorkbook.Save
  'End of the file editing
  localbook.Close
                 
Rng = "A" & i

 Range(Rng).Value = recMyFiles(i).sName

 Next i
 End With

macro_end:
 'MsgBox "There were no files found."
 End Sub

Open in new window

I have not been able to fully test it, but I think it should be most of the way there.
the main issue you may hev is that youmay need to add the file path delimiter '/' to recMyFiles(i).

ATB
Steve.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

This is pretty cool.  The purpose of this VB Script is to help you document where JAR (Java ARchive) files and specifically java class files are located so that you can address issues seen with a client or that you can speak intelligently with a dev…
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now