CODEWITHSUNDEEP
vbaexcel
Harshit Mehra
Harshit Mehra

Reputation: 41

Excel-VBA to compile data from multiple selected Excel files into one Analysed file

I have written a Macro that opens the selected file, searches where the error is occurred and then places it in the Summary file in the active cell. Its working perfectly but now I want that instead of selecting each file one by one i could select all required files together or i could open one file and it runs till the last file as the file name is in series i.e Motor 21, motor 22 and so on. there is some help give in this post but I don't know if I could use it.

http://www.mrexcel.com/forum/excel-questions/602222-macro-compile-data-multiple-excel-files-into-one-summary-file.html 

Sub InputData()

Dim fNameAndPath As Variant
Dim wb As Workbook, temporaryWB As Workbook
Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim SearchString As String, DateCol As String
Dim CumSum As Double, counter As Double, cum As Double
Dim strSheetName As String, CellName As String
Dim lastColumn As Long

Set wb = ThisWorkbook

strSheetName = ActiveSheet.Name
CellName = ActiveCell.Address
cum = Range(CellName).Offset(-1, 2).Value

fNameAndPath = Application.GetOpenFilename(Title:="Select File To Be Opened")
If fNameAndPath = False Then Exit Sub
Set temporaryWB = Workbooks.Open(fNameAndPath)

Set ws = ActiveSheet
Set oRange = ws.Range("C:C")

SearchString = "10000"

Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
    MatchCase:=False, SearchFormat:=False)


If Not aCell Is Nothing Then ' searching codeID string first time

    aCell.Select
    DateCol = aCell.Offset(0, -2)
    counter = aCell.Offset(0, -1)

    wb.Worksheets(strSheetName).Range(CellName) = DateCol
    wb.Worksheets(strSheetName).Range(CellName).Offset(0, 1) = counter

    CumSum = counter + cum
    wb.Worksheets(strSheetName).Range(CellName).Offset(0, 2) = CumSum
    wb.Worksheets(strSheetName).Range(CellName).Offset(0, 3) = "1000000"
    wb.Worksheets(strSheetName).Range(CellName).Offset(0, 4) = "50"

    lastColumn = ws.UsedRange.Columns.Count

    If InStr(1, ActiveCell.End(xlToRight).Offset(1, 3).Value, "1ms", vbTextCompare) <> 0 Then
        wb.Worksheets(strSheetName).Range(CellName).Offset(0, 6) = ActiveCell.End(xlToRight).Offset(1, 3)
        wb.Worksheets(strSheetName).Range(CellName).Offset(0, 7) = ActiveCell.End(xlToRight).Offset(1, 4)

    Else

        wb.Worksheets(strSheetName).Range(CellName).Offset(0, 6) = Application.InputBox("Enter error", "Dialog box", ActiveCell.End(xlToRight).Offset(1, 3), , , , , 2)
        wb.Worksheets(strSheetName).Range(CellName).Offset(0, 7) = Application.InputBox("Enter error", "Dialog box", ActiveCell.End(xlToRight).Offset(1, 4), , , , , 2)

    End If
Else
    MsgBox SearchString & " not Found"
    Exit Sub
End If

temporaryWB.Close savechanges:=False

End Sub

Upvotes: 0

Views: 261

Answers (1)

user4039065
user4039065

Reputation:

The Application.GetOpenFileName method has an optional multiselect parameter.

Working with a returned value that could be either False or an array of filenames and paths (even if that array is an array of one filename/path) is a bit tricky. Here is some framework that should get you started.

Sub collect_fns()
    Dim f As Long, fNameAndPath As Variant

    fNameAndPath = Application.GetOpenFilename("Excel files (*.xl*), *.xl*", _
                        Title:="Select File(s) To Be Opened", MultiSelect:=True)

    If IsArray(fNameAndPath) Then
        For f = LBound(fNameAndPath) To UBound(fNameAndPath)
            ' do something with each file as fNameAndPath(f)
            process_each_fn CStr(fNameAndPath(f))
        Next f
    Else
        'no files selected
    End If

End Sub

Sub process_each_fn(fn As String)

    Debug.Print fn

End Sub

It may help to move the bulk of your code to another sub and pass the filename into the new sub through the loop as I'm demonstrated above.

Upvotes: 2

Related Questions