Code To Open Files In A Folder And List All Different Data In AF.

[Dazzawm]

I have a blank sheet open. I would like a code to look in a folder and list the names of each different file in column A of the active sheet I am on. I also need it to look at column AF in each folder and list each different cell data next to the file name in column B, C, D and so on please. They're shouldn't be more than a dozen different, but multiple duplicates where only one is needed in column AF in each file. Thanks.

This is column AF in the first file in the folder called sample1

Description
Data 1
Data 2
Data 3
Data 4
Data 5
Data 6
Data 7

This is the result on the active sheet, columns B-H and so on with each other file in the folder.

File Name	Data In AF	Data In AF	Data In AF	Data In AF	Data In AF	Data In AF	Data In AF
Sample1	Data 1	Data 2	Data 3	Data 4	Data 5	Data 6	Data 7

The files are xlsb which have before close codes which need to be ignored.

 

[Dazzawm]

Using AI the below code does as I need, probably a lot of the code is not needed though.

Sub ListFilesAndColumnAFData()
    Dim folderPath As String
    Dim activeSheet As Worksheet
    Dim fileNames() As String
    Dim data As Object
    Dim file As Variant
    Dim rowIdx As Long
    Dim colIdx As Long
    Dim uniqueValues() As Variant
    Dim cellValue As Variant
    
    ' Replace "folderPath" with the path to the folder containing your files.
    ' Example: folderPath = "C:\Users\"
    folderPath = "C:\Users\"
    
    ' Set the active sheet where you want the data to be listed.
    Set activeSheet = ThisWorkbook.activeSheet
    
    ' Get the list of file names in the folder.
    fileNames = GetFileNames(folderPath)
    
    ' Initialize a dictionary to store column AF data for each file.
    Set data = CreateObject("Scripting.Dictionary")
    
    ' Loop through each file and read column AF data.
    For Each file In fileNames
        data(file) = GetColumnAFData(folderPath & file)
    Next file
    
    ' Write the data to the active sheet in the desired format.
    rowIdx = 1 ' Start from the first row (no header row).
    For Each file In data
        ' Write the file name in column A.
        activeSheet.Cells(rowIdx, 1).Value = file
        ' Get unique values from column AF data.
        uniqueValues = data(file)
        ' Write unique values in columns B, C, D, and so on.
        colIdx = 2
        For Each cellValue In uniqueValues
            activeSheet.Cells(rowIdx, colIdx).Value = cellValue
            colIdx = colIdx + 1
        Next cellValue
        rowIdx = rowIdx + 1
    Next file
End Sub

Function GetFileNames(folderPath As String) As String()
    Dim fileSystem As Object
    Dim folder As Object
    Dim file As Object
    Dim fileNames() As String
    Dim i As Long
    
    Set fileSystem = CreateObject("Scripting.FileSystemObject")
    Set folder = fileSystem.GetFolder(folderPath)
    ReDim fileNames(folder.Files.Count - 1) As String
    
    i = 0
    For Each file In folder.Files
        fileNames(i) = file.Name
        i = i + 1
    Next file
    
    GetFileNames = fileNames
End Function

Function GetColumnAFData(filePath As String) As Variant
    Dim Workbook As Workbook
    Dim sheet As Worksheet
    Dim lastRow As Long
    Dim columnAF As Range
    Dim cell As Range
    Dim uniqueValues As Collection
    Dim cellValue As Variant
    
    On Error Resume Next ' Avoid error if the file is not an Excel file.
    Set Workbook = Workbooks.Open(filePath)
    On Error GoTo 0
    
    If Not Workbook Is Nothing Then
        Set sheet = Workbook.Sheets(1) ' Assuming data is in the first sheet.
        lastRow = sheet.Cells(sheet.Rows.Count, "AF").End(xlUp).Row
        Set columnAF = sheet.Range("AF2:AF" & lastRow)
        
        Set uniqueValues = New Collection
        On Error Resume Next
        For Each cell In columnAF
            uniqueValues.Add cell.Value, CStr(cell.Value)
        Next cell
        On Error GoTo 0
        
        ReDim uniqueArray(uniqueValues.Count - 1) As Variant
        Dim i As Long
        For Each cellValue In uniqueValues
            uniqueArray(i) = cellValue
            i = i + 1
        Next cellValue
        
        GetColumnAFData = uniqueArray
        Workbook.Close SaveChanges:=False
    End If
End Function