Extracting information using VBA code help. 1

[gjsala]

Hi. I would like to search through many excel workbooks in a specific folder on my computer. My objective is to look at a specific tab (for example “Test”) in each workbook and copy the same two cells (B5 and B6) to a master Workbook starting with cells A1 and B1. This macro would create a large list. I have looked through text files to gather information but not excel workbooks. Thanks for your help in advance and here is what I have used in the past:

Function PickFolder(strStartDir As Variant) As String
'Selecting a folder to gather the text files and put into one excel spreadsheet.
Dim SA As Object, F As Object
Set SA = CreateObject("Shell.application")
Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
If (Not F Is Nothing) Then
PickFolder = F.Items.Item.Path
End If
Set F = Nothing
Set SA = Nothing
End Function
Sub V_Log()

Dim fso As Object, F As Object, Path As String
Dim CurrentRow As Range
Dim TextLine As String, NumCols As String
Dim CurWkb As Workbook
Dim CurWks As Worksheet
Dim numRows As Integer
Dim myRange As Range
Dim r As Long
Dim numR As Integer
Dim Data As String, myRight As String
On Error Resume Next
Application.ScreenUpdating = False
UserFile = PickFolder(strStartDir)
If UserFile = "" Then
MsgBox "Canceled"
Exit Sub
End If
Set CurWkb = Workbooks.Add
Set fso = CreateObject("Scripting.FileSystemObject")
For Each F In fso.GetFolder(UserFile).Files
If F.Type = "Text Document" Then
TheTextFile = UserFile & "\" & F.Name
FF = FreeFile()
Open TheTextFile For Input As FF
While Not EOF(FF)
Line Input #FF, TextLine
If Mid(TextLine, InStr(1, TextLine, ")") + 3, 5) = "Test" Then
Range("A65536").End(xlUp).Offset(1, 0) = TextLine
End If
Wend
Close #FF
End If
Next
End sub

 

[SkipVought]

hi,

Something like this might work...

Sub V_Log()
    Dim oFSO As Object, oFile As Object, sPath As String, wsThis As Worksheet, lRow As Long
    
    Set wsThis = ActiveSheet
    lRow = wsThis.[A1].CurrentRegion.Rows.Count + 1
    
    
    sPath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
    
    sPath = Left(sPath, InStrRev(sPath, "\") - 1)
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    For Each oFile In fso.GetFolder(UserFile).Files
        With Workbooks.Open(oFile.Name)
            wsThis.Cells(lRow, "A").Value = .Sheets("Test").[B5].Value
            wsThis.Cells(lRow, "B").Value = .Sheets("Test").[B6].Value
            
            lRow = lRow + 1
            
            .Close
        End With
    Next
End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[SkipVought]

Made a few changes...

Sub V_Log()
    Dim oFSO As Object, oFile As Object, sPath As String, wsThis As Worksheet, lRow As Long
    
    Set wsThis = ActiveSheet
    lRow = wsThis.[A1].CurrentRegion.Rows.Count + 1
        
    sPath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
    
    sPath = Left(sPath, InStrRev(sPath, "\") - 1)
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    For Each oFile In oFSO.GetFolder(sPath).Files
        If Split(oFile.Name, ".")(UBound(Split(oFile.Name, "."))) Like "xls*" Then
            With Workbooks.Open(oFile.Name)
                wsThis.Cells(lRow, "A").Value = .Sheets(1).[B5].Value
                wsThis.Cells(lRow, "B").Value = .Sheets(1).[B6].Value
                
                lRow = lRow + 1
                
                .Close
            End With
        End If
    Next
End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[gjsala]

Skip,
Thank you very much! It work like a champ!!!