Copying data to another workbook

So, I've got about 300 Excel workbook which all are basically the same. Now, I want the value from cell B48 and B54 to be copied to a separate workbook, a summary workbook, at a specific line which contains a text string that match the string from cell B6 in each workbook.

What would be the best approach to do this?
I thought, I could probably add a macro to each of the Workbooks at their Save handler which basically opens the other workbook, copies in the values, saves the workbook and then exits the macro and the workbook alltogether

But is there any other way of doing this? Would it be easier to have all the 300 workbooks in their own sheets? And then have one extra sheet that works as a summary sheet? Collecting data from all 300 sheets?

Hi,

As a one off if all the workbooks are saved in a folder it's quite straightforward to write some code which will loop through them all and grab the info you want as long as they are consistent with regards to populated cells, sheet names etc.

Dom

I'll pop an example together.

Dom

Not tested this but hopefully it works and makes sense.

Sub LoopFiles()

Dim strDir As String, strFileName As String
Dim rngSearchRange As Range, rngFindRange As Range
Dim wbReadBook As Workbook

strDir = "C:\"
strFileName = Dir(strDir & "*.xls")

' Specifies the sheet name and area within the summary workbook
' to look for string in B6 within each workbook, column A in this example
With ThisWorkbook.Sheets("Sheet1")
    rngSearchRange = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
End With

' Loop through workbooks
Do While strFileName <> ""
    Set wbReadBook = Workbooks.Open(strDir & strFileName)
    With wbReadBook.Sheets("Sheet1")    ' change sheet name to pull values from
' Find string in B6 within summary sheet
        Set rngFindRange = rngSearchRange.Find(.Range("B6"), LookIn:=xlValues, lookat:=xlWhole)
' If found populate adjacent cells or issue warning
        If Not rngFindRange Is Nothing Then
            rngFindRange.Offset(0, 1) = .Range("B48")
            rngFindRange.Offset(0, 2) = .Range("B54")
        Else
            MsgBox "No match found for " & strFileName, vbExclamation
        End If
    End With
    wbReadBook.Close False
    strFileName = Dir
Loop

End Sub

The code would go in a module within the summary workbook which should sit in a different directory to the other workbooks.

Dom

I get a run-time 91 - Object variable or With block variable not set at this line:

rngSearchRange = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)

Any idea why that is?

Btw: Which document should this code be added to anyway? This code should be added in each Excel document?

No, just in the summary workbook...

The code would go in a module within the summary workbook which should sit in a different directory to the other workbooks.

Make sure you change the sheet names in the code as well.

Dom

Originally Posted by Kenny Bones

Edit: Do you mean the this macro should be triggered from the Summary Workbook? Wouldn't that take an insane amount of time? Opening each 300 Workbooks, one after another?

Yes, that's correct.

Depends on the size of the workbooks and how long it takes to open them but if we turned off screen updating it probably wouldn't take more than a few mins.

Dom

I've added code to turn off screen updating and set calculation to manual while it runs which will speed things up.

Sub LoopFiles()

Dim strDir As String, strFileName As String
Dim rngSearchRange As Range, rngFindRange As Range
Dim wbReadBook As Workbook
Dim CalcState

Application.ScreenUpdating = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

On Error GoTo ErrorHandler

strDir = "C:\"
strFileName = Dir(strDir & "*.xls")

' Specifies the sheet name and area within the summary workbook
' to look for string in B6 within each workbook, column A in this example
With ThisWorkbook.Sheets("Sheet1")
    rngSearchRange = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
End With

' Loop through workbooks
Do While strFileName <> ""
    Set wbReadBook = Workbooks.Open(strDir & strFileName)
    With wbReadBook.Sheets("Sheet1")    ' change sheet name to pull values from
' Find string in B6 within summary sheet
        Set rngFindRange = rngSearchRange.Find(.Range("B6"), LookIn:=xlValues, lookat:=xlWhole)
' If found populate adjacent cells or issue warning
        If Not rngFindRange Is Nothing Then
            rngFindRange.Offset(0, 1) = .Range("B48")
            rngFindRange.Offset(0, 2) = .Range("B54")
        Else
            MsgBox "No match found for " & strFileName, vbExclamation
        End If
    End With
    wbReadBook.Close False
    strFileName = Dir
Loop

CleanExit:
Application.ScreenUpdating = True
Application.Calculation = CalcState
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Clear, vbCritical, "Error"
GoTo CleanExit

End Sub

Dom

My fault, it should be:

Set rngSearchRange = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)

And yes you can use:

With wbReadBook.Sheets(1)

To pick up the info from the first (or only) sheet in each workbook.

Dom

That seems promising
But I still don't see why the macro should be triggered from the Summary workbook. Wouldn't it be a lot easier to just have a macro triggered at the Save Handler in each workbook instead? Pseudo code:

Private Sub Workbook_BeforeSave()
       strName = cell(B6)
       intValue1 = Cell(B46)
       intValue2 = Cell(B53)

       Open summary workbook
       Search for strName
       Select Cell
       ActiveCell.Offset (0,1).Value = intValue1
       ActiveCell.Offset(0,2).Value = intValue2

       If strName is not found
              Go to lowest empty cell
              cell.value = strName
              cell.Offset(0,1).Value = intValue1
              cell.Offset(0,2).Value = intValue2
       End if
End Sub

Something's happening to the strings when I pick them up via ADODB connection. This really doesn't make any sense.

Ok, I collect the values in the function and pass them back. Then, I search for the first string in the array and I get no matches. But, If I manually assign the Var(0) to be the exact same as it was before, everything works just fine!

Here's a screenshot: http://img641.imageshack.us/img641/4043/unledozi.png

So, something is happening here. Here's my full code that's a bit altered from your last one. Notice how I specifically collect only the three cells I want the value from in that function you created. Then I merge these to an array, which is passed back to the initial sub.

Public Sub collectData()
    Dim ws As Worksheet
    Dim strDir As String, strFileName As String
    Dim rngSearchRange As Range, rngFindRange As Range
    Dim wbReadBook As Workbook
    Dim CalcState
    Dim Var As Variant
    
    Set ws = ThisWorkbook.Sheets(1)
    
    Application.ScreenUpdating = False
    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    'On Error GoTo ErrorHandler
    
    strDir = "C:\Users\vsando\Documents\Mine Prosjekter\Arbeidsklær\"
    strFileName = Dir(strDir & "*.xls")
    
    ' Specifies the sheet name and area within the summary workbook
    ' to look for string in B6 within each workbook, column A in this example
       
    Set rngSearchRange = ws.Range(ws.[a2], ws.Cells(Rows.Count, "A").End(xlUp))
    
    ' Loop through workbooks
    Do While strFileName <> ""
        Var = returnResults(strDir & strFileName)
            If VarType(Var) = vbBoolean Then Err.Raise 75
    ' Find string in B6 within summary sheet
            Set rngFindRange = rngSearchRange.Find(Var(0), LookIn:=xlValues, lookat:=xlWhole)
            ' No results are found, even though the value of Var(0) is "apples bananas"
            Var(0) = "apples bananas"
            ' Now it can find it just fine!
            Set rngFindRange = rngSearchRange.Find(Var(0), LookIn:=xlValues, lookat:=xlWhole)
            
            If Not rngFindRange Is Nothing Then
                MsgBox Var(0) & " found in" & rngFindRange.Address(0, 0)
            Else
                MsgBox Var(0) & " not found in:"
            End If
            
            
            'Set rngFindRange = rngSearchRange.Find(Range("B6"), LookIn:=xlValues, lookat:=xlWhole)
            
    ' If found populate adjacent cells or issue warning
            If Not rngFindRange Is Nothing Then
                rngFindRange.Offset(0, 1) = Val(Var(0, 0))
                rngFindRange.Offset(0, 2) = Val(Var(0, 6))
            Else
                'AddRows (Val(var(0, 0)))
                'AddRows (Val(var(0, 6)))
                
                MsgBox "No match found for " & strFileName, vbExclamation
            End If
        strFileName = Dir
    Loop
    
CleanExit:
    Application.ScreenUpdating = True
    Application.Calculation = CalcState
    
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Name, vbCritical, "Error"
    GoTo CleanExit

End Sub

Function returnResults(FilePath As String) As Variant
    Dim mergedArray(2) As Variant
    Dim strNavn As String
    Dim intSommer As Integer
    Dim intVinter As Integer
    
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    
    Const strQueryName = "SELECT * FROM [B5:B6];"
    Const strQuerySommer = "SELECT * FROM [B48:B49];"
    Const strQueryVinter = "SELECT * FROM [B54:B55];"
    
    Const strQuery As String = "SELECT * FROM [B5:B54];"
    
    'On Error GoTo Handler
        
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & FilePath & ";" & _
            "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    
    Set rs = New ADODB.Recordset
        
    rs.Open strQueryName, cn, adOpenStatic, adLockReadOnly
    strNavn = rs.GetString
    rs.Close
    
    rs.Open strQuerySommer, cn, adOpenStatic, adLockReadOnly
    intSommer = rs.GetString
    rs.Close
    
    rs.Open strQueryVinter, cn, adOpenStatic, adLockReadOnly
    intVinter = rs.GetString
    
    mergedArray(0) = strNavn
    mergedArray(1) = intSommer
    mergedArray(2) = intVinter
                
    returnResults = mergedArray
    
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    
    Exit Function
    
Handler:
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    
    returnResults = False
End Function

Edit: What's really strange here is that if I take the value from Var(0) and assign that value to one of the cells in the Excel sheet and then re-run the code, it can find it!
Even though it looks exactly the same. I just use "ws.Cells(5,1).Value = Var(0)" and see that the string is the exact same. But somehow Var(0) differs. I've also checked if there are any white spaces and there are none. Also, both cells are formatted exactly the same.