Results 1 to 14 of 14

File picker in excel 2007

Threaded View

  1. #1
    Forum Contributor
    Join Date
    07-30-2012
    Location
    australia
    MS-Off Ver
    Excel 2003
    Posts
    118

    File picker in excel 2007

    Currently I am using this code in excel 2003, but it gives me an error in excel 2007 when using the below code: the object cannot be supported.
    Sub cmdAdd_Click()
    
       Dim items As FileDialogSelectedItems
        Dim ws As Worksheet
        Dim rng As Range
        Dim Ur As Range
        Dim fs
        Dim r As Integer    ' row marker
        Set ws = ThisWorkbook.Worksheets("data")
        'ThisWorkbook.Worksheets("Names").Activate
        
        Set items = PickFiles()
        'MsgBox items.Count
        ' If there is no file selected, exit the rountine
        If items.Count = 0 Then
            Exit Sub
        End If
        ws.Activate
        If Range("A1").Value = "" Then
        Set rng = ws.Columns(1)
        ElseIf Range("A2").Value = "" Then
        Range("A1").Select
        Set Ur = Range("A1")
        Set rng = Intersect(Ur, ws.Columns(1))
        r = rng.Count + 1
        Else
        Range("A1").Select
        Set Ur = Range(Selection, Selection.End(xlDown))
        Set rng = Intersect(Ur, ws.Columns(1))
        r = rng.Count + 1
            End If
        
        ' Happens when all cells are empty
        If rng.Count = 1 And ws.Cells(1, 1).Value = "" Then
            r = 1
        End If
    
        ' Put the selected files on the list
        Dim val
        For Each val In items
            Set fs = Application.FileSearch
            With fs
            .LookIn = val
            .SearchSubFolders = True
            .Filename = "*.*"
            If .Execute > 0 Then
        
            ' MsgBox "There were " & .FoundFiles.Count & _
            '      " file(s) found."
                For i = 1 To .FoundFiles.Count
                    ws.Cells(r, 1).Value = .FoundFiles(i)
                    r = r + 1
                Next
            End If
            End With
        Next
        
        ws.Columns(1).AutoFit
    
       ' Call CheckList
    
    End Sub
    Function GetFolder() As FileDialogSelectedItems
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = True
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
    NextCode:
    
    
    Set GetFolder = fldr.SelectedItems
    'Set fldr = Nothing
    End Function
    
    
    Sub Macro2()
    Application.ScreenUpdating = True
    Dim r, k
    Dim wk As Workbook
    k = 2
    r = ThisWorkbook.Worksheets(1).Cells(1, 26).Value
    For i = 1 To r
    
        
        
        w = ThisWorkbook.Worksheets(1).Cells(i, 1).Value
        
        Set wk = Workbooks.Open(w, Flase, True)
        a = wk.Worksheets(1).Cells(4, 5).Value
        b = wk.Worksheets(1).Cells(6, 7).Value
        ThisWorkbook.Activate
          
        'ThisWorkbook.Worksheets(a).Cells(3, 3).Value = ThisWorkbook.Worksheets(1).Cells(i, 2).Value
     
        j = 20
        
        Do
           'MsgBox Workbooks(b).Worksheets(i).Cells(4, 3).Value
           'MsgBox wk.Worksheets(j).Name
           If wk.Worksheets(j).Cells(24, 4).Value <> "" Then
           
           For n = 40 To 68
           If n = 49 Then
            n = 55
            ElseIf n = 57 Or n = 65 Then
            n = n + 1
            End If
            If UCase(wk.Worksheets(j).Cells(n, 5).Value) <> UCase(wk.Worksheets(j).Cells(n, 6).Value) Then
            c = Right(wk.Worksheets(j).Cells(6, 3).Value, 9)
            c = LTrim(c)
            ThisWorkbook.Worksheets(2).Cells(k, 1).Value = a
            ThisWorkbook.Worksheets(2).Cells(k, 2).Value = b
            ThisWorkbook.Worksheets(2).Cells(k, 3).Value = wk.Worksheets(j).Cells(5, 5).Value
            ThisWorkbook.Worksheets(2).Cells(k, 4).Value = wk.Worksheets(j).Cells(6, 5).Value
            ThisWorkbook.Worksheets(2).Cells(k, 5).Value = wk.Worksheets(j).Cells(4, 7).Value
            ThisWorkbook.Worksheets(2).Cells(k, 6).Value = wk.Worksheets(c).Cells(5, 7).Value
            ThisWorkbook.Worksheets(2).Cells(k, 7).Value = wk.Worksheets(j).Cells(5, 7).Value
            ThisWorkbook.Worksheets(2).Cells(k, 8).Value = wk.Worksheets(j).Cells(n, 3).Value
            ThisWorkbook.Worksheets(2).Cells(k, 9).Value = wk.Worksheets(j).Cells(n, 5).Value
            ThisWorkbook.Worksheets(2).Cells(k, 10).Value = wk.Worksheets(j).Cells(n, 6).Value
            ThisWorkbook.Worksheets(2).Cells(k, 11).Value = wk.Worksheets(j).Cells(n, 7).Value
            k = k + 1
             End If
              
            Next
            
            Else
            Exit Do
            End If
            j = j + 1
        Loop
        'MsgBox a + ".xls"
        
        wk.Close SaveChanges:=False
    Next i
    
        
    End Sub
    
    Sub Macro3()
    Dim r
    r = ThisWorkbook.Worksheets(1).Cells(1, 26).Value
    For i = 3 To r + 2
    
    ThisWorkbook.Worksheets("overall").Cells(i - 1, 1).Value = ThisWorkbook.Worksheets(i).Cells(3, 3).Value
    ThisWorkbook.Worksheets("overall").Cells(i - 1, 2).Value = ThisWorkbook.Worksheets(i).Cells(3, 2).Value
    ThisWorkbook.Worksheets("overall").Cells(i - 1, 3).Value = ThisWorkbook.Worksheets(i).Cells(17, 21).Value
    Next
    End Sub
    
    Public Function PickFiles() As FileDialogSelectedItems
    
        Dim fd As FileDialog
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        
        fd.AllowMultiSelect = True
        
        fd.Filters.Clear
        fd.Filters.Add "excel Files", "*.xls"
        
        fd.Show
        
    '    If fd.SelectedItems.Count = 0 Then
    '        Set BrowseFile = Nothing
    '        Exit Function
    '    End If
        
        Set PickFiles = fd.SelectedItems
        
    End Function
    Can someone help me to execute the above code to execute in excel 2007?

    Any response would be appreciated.
    Last edited by irfanparbatani; 09-18-2012 at 08:55 PM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1