CODEWITHSUNDEEP
vbaexcel
user3233328
user3233328

Reputation: 397

Excel VBA Open Workbooks without duplicating it

I have a list of filenames in one of my workbook. I was wondering if anyone knows how to open the file when the name is not in that list. For example, the list contains names for file “ab”, “bc”, “cd” & “de”. File “ac”, “bd” & “eg” are not in the list, and I only want to open that files so there is no duplication. I know I can just remove the duplication, but it’s time consuming to open files that already exist in the list. I’m new with VBA and I did some research about this topic, but found nothing. I really appreciate anyone that can help me. Thank you!

So here is what I came up so far:

Sub Test1()

Dim File As String
Dim wb As Workbook
Dim wbList As Workbook
Dim filesRange As Range
Dim f As Range
Dim fileName As String
Dim Average As Double
Dim StdDev As Double
Dim OpenNum As Double
Dim Min As Double
Dim Max As Double
Dim wbDestination As Workbook

Const wbPath As String = "C:\Users\10 stop.xlsx"
Const pathToFiles As String = "C:\Users\J\"

File = Dir(pathToFiles, vbDirectory)

Set wbList = Workbooks.Open(wbPath)
Set filesRange = wbList.Sheets("18x17 - 10 mil stop").Range("A:A")

Do While Len(File) > 0
    Set f = filesRange.Find(What:=f, LookIn:=xlValues, Lookat:=xlWhole)
    If f Is Nothing Then
        Set wb = Workbooks.Open(pathToFiles & File)

        fileName = ActiveWorkbook.Name
        Worksheets(1).Select
        Average = Range("B15")
        Worksheets(1).Select
        StdDev = Range("B16")
        Worksheets(1).Select
        OpenNum = Range("B13")
        Worksheets(1).Select
        Min = Range("B17")
        Worksheets(1).Select
        Max = Range("B18")

        Set wbDestination = Workbooks.Open("C:\Users\10 stop.xlsx")
        Worksheets(ActiveSheet.Name).Select
        Worksheets(ActiveSheet.Name).Range("a1").Select
        RowCount = Worksheets(ActiveSheet.Name).Range("a1").CurrentRegion.Rows.Count
        With Worksheets(ActiveSheet.Name).Range("a1")
        .Offset(RowCount, 0) = fileName
        .Offset(RowCount, 1) = Average
        .Offset(RowCount, 2) = StdDev
        .Offset(RowCount, 3) = OpenNum
        .Offset(RowCount, 4) = Min
        .Offset(RowCount, 5) = Max
        End With
    End If
    File = Dir()
Loop
End Sub

I got Runtime-error '5': Invalid Procedure Call or Argument on

Set f = filesRange.Find(What:=f, LookIn:=xlValues, Lookat:=xlWhole)

For the files that I want to open and read, I would like to use wildcard "-10_.csv" I tried many different ways, but all of them gave me blank sheets as result. I used the 'RecursiveDir' previously, but it's slow and open every files over and over again when I try to update my data. This is so frustrating :( Please help!

Upvotes: 2

Views: 427

Answers (1)

Tim Williams
Tim Williams

Reputation: 166196

Added sub-folder searching. Compiled but not tested.

Sub Test1()

Dim wb As Workbook
Dim wbList As Workbook
Dim filesRange As Range
Dim f As Range
Dim wbDestination As Workbook
Dim rw As Range
Dim allFiles As New Collection, File, fName

Const wbPath As String = "C:\Users\10 stop.xlsx"
Const pathToFiles As String = "C:\Users\J\"

    Set wbList = Workbooks.Open(wbPath)
    Set filesRange = wbList.Sheets("18x17 - 10 mil stop").Range("A:A")

    GetFiles pathToFiles, "*-10_.csv", True, allFiles

    For Each File In allFiles

        fName = FileNameOnly(File)

        Set f = filesRange.Find(What:=fName, LookIn:=xlValues, Lookat:=xlWhole)

        If f Is Nothing Then

            Set wb = Workbooks.Open(File)

            '***need to specify sheet name below...
            Set rw = wbList.Sheets("sheetname").Cells(Rows.Count, 1) _
                       .End(xlUp).Offset(1, 0).EntireRow

            rw.Cells(1).Value = fName 'or `File` if you want the full path
            With wb.Sheets(1)
                rw.Cells(2).Value = .Range("B15").Value 'avg
                rw.Cells(3).Value = .Range("B16").Value 'stdev
                rw.Cells(4).Value = .Range("B13").Value 'opennum
                rw.Cells(5).Value = .Range("B17").Value 'min
                rw.Cells(6).Value = .Range("B18").Value 'max
            End With
            wb.Close False 'don't save

        End If
    Next File

End Sub

'given a path, return only the filename
Function FileNameOnly(sPath)
Dim arr
    arr = Split(sPath, "\")
    FileNameOnly = arr(UBound(arr))
End Function




Sub GetFiles(StartFolder As String, Pattern As String, _
             DoSubfolders As Boolean, ByRef colFiles As Collection)

    Dim f As String, sf As String, subF As New Collection, s

    If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"

    f = Dir(StartFolder & Pattern)
    Do While Len(f) > 0
        colFiles.Add StartFolder & f
        f = Dir()
    Loop

    sf = Dir(StartFolder, vbDirectory)
    Do While Len(sf) > 0
        If sf <> "." And sf <> ".." Then
            If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
                    subF.Add StartFolder & sf
            End If
        End If
        sf = Dir()
    Loop

    For Each s In subF
        GetFiles CStr(s), Pattern, True, colFiles
    Next s

End Sub

Upvotes: 2

Related Questions