Reference cells from 3000 seperate PO.xls to single Workbook

[shbrouwer]

I am trying to consolidate multiple PO's into a single sheet.
Currently my PO are saved as follows
NQ_PO 1.xls
NQ_PO 2.xls
NQ_PO 3.xls etc.

='J:\Excel Purchase Order Files\2007-2009\[NQ_PO 1.xls]Sheet1'!C6

I referenced one file, but it wants me to "Update Values: NQ_PO 2.xls" when I copy the formula down to the next row.

Do I have to manually select all 3000 PO's?

Any advise is apreciated

 

[Case_Germany]

Do I have to manually select all 3000 PO's?

Not really - that's comfortable with VBA. Take a new file - copy the code into a module and customize the path (strDir = "C:\Project\") - then give it a try:

Option Explicit
' This worksheet is read out
Const strSheetQ As String = "Sheet1"
' This worksheet is in the file with this code
Const strSheetZ As String = "Sheet1"
' This cell is read out
Const strCellQ As String = "C6"
Public Sub Files_Read()
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        intCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' File in the same folder as evaluation files
    ' strDir = ThisWorkbook.Path & "\"
    ' Fixed folder specified
    strDir = "C:\Project\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.GetFolder(strDir)
    With ThisWorkbook.Worksheets(strSheetZ)
        ' Delete everything from row 2 down
        .Rows("2:" & .Rows.Count).ClearContents
        ' dirInfo objDir, "*.xls*", True ' with subfolders
        dirInfo objDir, "*.xls*" ' without subfolders
        ' Convert formulas to values
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    With Application
        .Goto (ThisWorkbook.Worksheets(strSheetZ).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = intCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim objWorkbook As Workbook
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            With ThisWorkbook.Worksheets(strSheetZ)
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                    .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                With .Cells(lngLastRow, 1)
                    .Formula = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                        strSheetQ & "'!" & strCellQ
                End With
            End With
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub

 

[shbrouwer]

Wow it works great, Thank you.

It is too complicated for me to elabirate on it, but it is good to know that what I was looking for is possible.

I am thinking of taking this to a programmer to finish. Hope thats ok to use your programming?

Would you consider working on it?
My only concerns:
Every so often our PO layout changes, I guess we could start a new folder for every PO style, or would it be easy for me to edit cell references?

Also i would like to reference from each workbook 8-10 cells.

Thanks Again

 

[Case_Germany]

Hi,

if only one cell is to be read, then you need only change one line (Const strCellQ As String = "C6"). If multiple cells are read, the question arises whether these cells are a contiguous area (such as A5:A20 or B10:C33), or discontinuous (such as A3, B17, H44 and so on).

 

[shbrouwer]

My Cell References would be as follows "C6,C9,F11,C16,C22,H93,H109,J62"
Each one to appear on the same row in separate columns per file.

Thanks

 

[Case_Germany]

Hi,

we do this with an array:

Option Explicit
' This worksheet is read out
Const strSheetQ As String = "Sheet1"
' This worksheet is in the file with this code
Const strSheetZ As String = "Sheet1"
Public Sub Files_Read()
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        intCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' File in the same folder as evaluation files
    ' strDir = ThisWorkbook.Path & "\"
    ' Fixed folder specified
    strDir = "C:\Project\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.GetFolder(strDir)
    With ThisWorkbook.Worksheets(strSheetZ)
        ' Delete everything from row 2 down
        .Rows("2:" & .Rows.Count).ClearContents
        ' dirInfo objDir, "*.xls*", True ' with subfolders
        dirInfo objDir, "*.xls*" ' without subfolders
        ' Convert formulas to values
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    With Application
        .Goto (ThisWorkbook.Worksheets(strSheetZ).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = intCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim objWorkbook As Workbook
    Dim strFormula As String
    Dim strRange As String
    Dim lngLastRow As Long
    Dim arrCell As Variant
    Dim intTMP As Integer
    Dim varTMP As Variant
    arrCell = Array("C6", "C9", "F11", "C16", _
        "C22", "H93", "H109", "J62")
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            With ThisWorkbook.Worksheets(strSheetZ)
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                    .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                For intTMP = 1 To 8
                    strRange = arrCell(intTMP - 1)
                    strRange = Range(strRange).Address(RowAbsolute:=True, _
                        ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
                    '.Cells(lngLastRow, 1).Value = varTMP.Path ' with Path
                    '.Cells(lngLastRow, 1).Value = varTMP.Name ' only Filename
                    .Cells(lngLastRow, intTMP).Formula = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange
                    ' If the file name should be (with or without path)
                    ' in the first column, then take these lines
                    '.Cells(lngLastRow, intTMP + 1).Formula = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange
                Next intTMP
            End With
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub