Code To Open All Files In A Folder And Give Me A List Of Numbers In Each.

[Dazzawm]

I don't feel an example is necessary here but please let me know if it is. I have a blank worksheet. I need a code that will open all files within a folder on my desktop, look at column AD in sheet 1 in each file then list each unique number that is in each file on the blank worksheet please. Thanks

N.B there may be 100's of the same number in each file so it only needs listing once in the final result. Also each file is an .xlsm which has before close events in each which need to be ignored when the file is closed.

Thanks again.

 

[Eric W]

Open a NEW workbook. Press Alt-F11 to open the VBA editor. From the menu, click Insert > Module. Paste the following code into the sheet that opens:

Sub GetData()
    Dim fso As Object, fldStart As Object
    Dim MaxRows As Long, MyDict As Object, MyCol As Long, MyPath As String, MyData As Variant

    Application.ScreenUpdating = False
    
    MyPath = "C:\Users\yourname\Desktop\Excel"
    MaxRows = 100
    MyCol = 2
    
    Set fso = CreateObject("scripting.FileSystemObject")
    Set fldStart = fso.GetFolder(MyPath)
    
    For Each f In fldStart.Files
        If f.Name Like "*.xl*" Then
            Range("A1:A" & MaxRows).Formula = "=INDEX('" & MyPath & "\[" & f.Name & "]Sheet1'!AD:AD,ROW())"
            Set MyDict = CreateObject("Scripting.Dictionary")
            MyData = Range("A1:A" & MaxRows).Value
            For i = 1 To MaxRows
                If MyData(i, 1) <> 0 Then MyDict(MyData(i, 1)) = MyDict(MyData(i, 1)) + 1
            Next i
            Cells(1, MyCol) = f.Name
            Range(Cells(2, MyCol), Cells(MyDict.Count + 1, MyCol)).Value = WorksheetFunction.Transpose(MyDict.keys)
            MyCol = MyCol + 1
            Set MyDict = Nothing
        End If
            
    Next f
    
    Range("A:A").ClearContents
    Application.ScreenUpdating = True
    
End Sub

Change the path name in red to the path of your folder. Change the MaxRows value to the maximum number of rows that any sheet will have. Pick a big number if you're not sure how many there are. Then either press F5 or go back to Excel and select it from the macro selector (Alt-F8).

This routine does not actually open any of the files, it creates a worksheet function that can reference a closed file, then processes those values internally. This way we don't have to worry about the BeforeClose macros. Let me know how this works.

 

[Dazzawm]

Thank you I will try when back at work in the morning. There is one further thing though which I forgot. Would it be possible to put what is next to the part number in column AE also? If it means completely having to rewrite then don't worry this will be fine.

 

[Eric W]

Not a huge change:

Sub GetData()
    Dim fso As Object, fldStart As Object
    Dim MaxRows As Long, MyDict As Object, MyCol As Long, MyPath As String, MyData As Variant

    Application.ScreenUpdating = False
    
    MyPath = "C:\Users\yourname\Desktop\Excel"
    MaxRows = 100
    MyCol = 3
    
    Set fso = CreateObject("scripting.FileSystemObject")
    Set fldStart = fso.GetFolder(MyPath)
    
    For Each f In fldStart.Files
        If f.Name Like "*.xl*" Then
            Range("A1:A" & MaxRows).Formula = "=INDEX('" & MyPath & "\[" & f.Name & "]Sheet1'!AD:AD,ROW())"
            Range("B1:B" & MaxRows).Formula = "=INDEX('" & MyPath & "\[" & f.Name & "]Sheet1'!AE:AE,ROW())"
            Set MyDict = CreateObject("Scripting.Dictionary")
            MyData = Range("A1:B" & MaxRows).Value
            For i = 1 To MaxRows
                If MyData(i, 1) <> 0 Then MyDict(MyData(i, 1)) = MyData(i, 2)
            Next i
            Cells(1, MyCol) = f.Name
            Range(Cells(2, MyCol), Cells(MyDict.Count + 1, MyCol)).Value = WorksheetFunction.Transpose(MyDict.keys)
            Range(Cells(2, MyCol + 1), Cells(MyDict.Count + 1, MyCol + 1)).Value = WorksheetFunction.Transpose(MyDict.items)
            MyCol = MyCol + 3
            Set MyDict = Nothing
        End If
            
    Next f
    
    Range("A:B").ClearContents
    Application.ScreenUpdating = True
    
End Sub

 

[jim may]

Here's a NEW sample worksheet file I created, along with 2 macros to achieve what you want. The Macro GetMyData will populate Column A with ALL numbers from All Workbooks. The Macro CreateUniqueList will examine Column A and eliminate duplicates providing the unique list into Column C and Sorted in ascending order.
Hope this helps.

Jim


Excel 2010

	A	B	C
1	My Import		Unique #'s

<tbody>
</tbody>

Sheet1​

Sub GetMyData()
    Dim sFName As String
    Dim sPath As String
    Dim i As Integer
    Application.ScreenUpdating = False
    i = 2         'the row # to start on
    sPath = "C:\Users\Owner\Documents\ExcelChest\Sub_WorkBooks\"
    ChDir sPath
    sFName = Dir("Wb9?.xlsm")   'I have 3 xlsm files: Wb91.xlsm; Wb92.xlsm; Wb93.xlsm
    Do While Len(sFName) > 0
        Workbooks.Open (sFName)
        With ActiveWorkbook.Worksheets("Cover").Columns(1)  'Data I want is in Sheetname "Cover"
            SLR = .Range("A" & Rows.Count).End(xlUp).Row    'Numbers I want are in Column A
            Range("A1:A" & SLR).Copy
        End With
        Application.EnableEvents = False
        Workbooks(sFName).Close False
        Application.EnableEvents = True
        With ActiveSheet
            DLR = .Range("A" & Rows.Count).End(xlUp).Row + 1
            .Range("A" & DLR).Select
            .Paste
        End With
        sFName = Dir
        i = i + 1
    Loop
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Sub CreateUniqueList()
Dim TargetRange As Range
Dim colMain As New Collection
LR = WorksheetFunction.Max(Range("C" & Rows.Count).End(xlUp).Row, 2) 'This is your Output Range
Range("C2:C" & LR).ClearContents
LR = Range("A" & Rows.Count).End(xlUp).Row    'This is your Source Range
Set TargetRange = Range("A2:A" & LR)
On Error Resume Next
For Each Cell In TargetRange
   CellValue = Cell.Value
   colMain.Add CellValue, CStr(CellValue)
    If Err.Number = 0 Then
      ' new item was added proceed without doing anything
    Else
      ' item already exists - you need to clear the error - see next
      Err.Clear
   End If
Next
j = colMain.Count
For i = 2 To j + 1
Application.Calculation = xlCalculationManual
Cells(i, 3).Value = colMain(i - 1)
Next i
LR = Range("C" & Rows.Count).End(xlUp).Row   'This is your Output Range
Set OutputRange = Range("C2:C" & LR)
OutputRange.Select
With ActiveSheet
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=ActiveCell, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumber
End With
With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange OutputRange
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
End With
Application.Calculation = xlCalculationAutomatic
Range("C1").Select
End Sub

After Running Both Macros my Worksheet Looks like this...

Excel 2010

	A	B	C
1	My Import		Unique #'s
2	111		111
3	112		112
4	111		211
5	112		212
6	446		311
7	211		312
8	212		446
9	211		846
10	212		1246
11	846
12	311
13	312
14	311
15	312
16	1246

<tbody>
</tbody>

Sheet1​

 

[Dazzawm]

Thank you both. Eric W I tried both of yours and each code said subscript out of range. When I selected OK it did make a list although it listed each number that was in each file and not unique numbers (so many 100's of the same number).

Jim May when I run your code nothing happened at all? I am guessing I have to put what each file is called? The code could be used for several files all of long different type titles, so none would start the same i.e wb9? like yours. So would be difficult to embed each file name into the code.

Thanks both again.

 

[jim may]

Dazzawm,

My submission was a STANEALONE application Having Nothing to do with your specific data. It was provided ONLY as an EXAMPLE (a teachable tool) of how to achieve a task which is as similar as possible to your App.

Good Luck,
Jim

 

[Dazzawm]

I misunderstood, in your post you said 'Here's a NEW sample worksheet file I created, along with 2 macros to achieve what you want.' so I assumed it would work on my files.

 

[Eric W]

Where did it say subscript out of range? The code should have stopped on a particular line. Offhand, I can think of 2 places it might occur. First, if you set the MaxRows too high. If you want it to check every row in the workbooks, change it to

MaxRow = Rows.Count

The second place would be if you had a workbook in that folder that does not have a Sheet1 in it, it's been renamed to something else. Let me know, and we'll see if we can figure it out.

 

[Dazzawm]

Yes it was probably the amount of rows to high, one sheet may be 30000 another may be 100000. I will try the rows.count and get back to you.