CODEWITHSUNDEEP
excelvba
Robert
Robert

Reputation: 27

Looping through a folder with Excel files scraping date from selected cells using VBA

I would like to loop through Excel files in a specific folder. After opening a single file, the macro goes to a specified tab to copy data from four cells (say A2; B3; C5 and D6 which I have named Region, DateSales, Sales and Salesman) to a master file.

I found VBA code.

Sub getDataFromWbs()

    Dim wb As Workbook, ws As Worksheet
    Dim Region As String
    Dim DateSales As Date
    Dim Sales As Integer
    Dim Salesman As String

    Application.ScreenUpdating = False

    Set fso = CreateObject("Scripting.FileSystemObject")

    'Path to the folder
    Set fldr = fso.GetFolder("C:\Users\xxxxx\yyyyyy\Desktop\Sales\")

    'Next available row in Master Workbook
    y = ThisWorkbook.Sheets("Sheet1").Cells(rows.Count, 1).End(xlUp).Row + 1

    'Loop through each file in that folder
    For Each wbFile In fldr.files

        'Make sure looping only through files ending in .xlsx (Excel files)
        If fso.GetExtensionName(wbFile.Name) = "xlsx" Then

            'Open current book
            Set wb = Workbooks.Open(wbFile.Path)

            Region = Sheets(1).Cells(1, 2).Value
            DateSales = Sheets(1).Cells(2, 3).Value
            Sales = Sheets(1).Cells(3, 5).Value
            Salesman = Sheets(1).Cells(4, 6).Value

            'Loop through each sheet (ws)
            For Each ws In wb.Sheets

                'Last row in that sheet (ws)
                wsLR = ws.Cells(rows.Count, 1).End(xlUp).Row

                'Loop through each record (row 2 through last row)
                For x = 2 To wsLR
                
                'Put column 1,2,3 and 4 of current sheet (ws) into row y of master sheet, then increase row y to next row
                    ThisWorkbook.Sheets("Sheet1").Cells(y, 1) = ws.Cells(x, 1).Value = Region 'col 1
                    ThisWorkbook.Sheets("Sheet1").Cells(y, 2) = ws.Cells(x, 2).Value = DateSales
                    ThisWorkbook.Sheets("Sheet1").Cells(y, 3) = ws.Cells(x, 3).Value = Sales
                    ThisWorkbook.Sheets("Sheet1").Cells(y, 4) = ws.Cells(x, 4).Value = Salesman

                    y = y + 1
                Next x

            Next ws

            'Close current book
            wb.Close

        End If

    Next wbFile

End Sub

The end results are FALSE and TRUE values in the master file.

Upvotes: 1

Views: 146

Answers (2)

VBasic2008
VBasic2008

Reputation: 54767

Import Cell Values From Closed Workbooks (FSO)

Option Explicit

Sub ImportData()

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")

    Dim fsoFolder As Object
    Set fsoFolder = fso.GetFolder("C:\Users\xxxxx\yyyyyy\Desktop\Sales\")

    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Sheets("Sheet1")
    Dim dRow As Long: dRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row ' last

    Application.ScreenUpdating = False

    Dim swb As Workbook, sws As Worksheet, fsoFile As Object, sPath As String

    For Each fsoFile In fsoFolder.Files
        
        sPath = fsoFile.Path
        
        If StrComp(fso.GetExtensionName(sPath), "xlsx", vbTextCompare) = 0 Then
            
            Set swb = Workbooks.Open(sPath)
            Set sws = swb.Worksheets(1)
            
            dRow = dRow + 1 ' next
            
            dws.Cells(dRow, "A").Value = sws.Range("A2").Value
            dws.Cells(dRow, "B").Value = sws.Range("B3").Value
            dws.Cells(dRow, "C").Value = sws.Range("C5").Value
            dws.Cells(dRow, "D").Value = sws.Range("D6").Value
            
            swb.Close SaveChanges:=False ' only read from
        
        End If
    
    Next fsoFile

    Application.ScreenUpdating = True

    MsgBox "Data imported.", vbInformation

End Sub

Upvotes: 0

leosch
leosch

Reputation: 561

As mentioned in the comments, you write the result of comparison to the cells value. Which will be TRUE or FALSE, thats what you see as a result. To copy the actual data, try to change these four lines of code:

    ThisWorkbook.Sheets(1).Cells(y, 1) = ws.Cells(x, 1).Value ' Region
    ThisWorkbook.Sheets(1).Cells(y, 2) = ws.Cells(x, 2).Value ' DateSales
    ThisWorkbook.Sheets(1).Cells(y, 3) = ws.Cells(x, 3).Value ' Sales
    ThisWorkbook.Sheets(1).Cells(y, 4) = ws.Cells(x, 4).Value ' Salesman

Upvotes: 0

Related Questions