Extracting data from similar cell in 720 excel files that in 12 folders

[javad118]

I want to extract data from similar cells in 720 Excel files that in 12 folders (It means every folder has 60 excel files)and put extracted data in 1 column in another excel files and process these data .
My email is:{moderator removed} for more information plz help me
it is very vital for me

 

[Richard Schollar]

Hi

Do you know the name of the sheets (not the index ie the first or second sheet) and the specific cell address in each of these sheets in each of these files?

 

[al_b_cnu]

Hi,

Based on info from your other post, try the following, amend the constant 'msTargetsheet' to suit.

Option Explicit
Const msSourceSheet As String = "Amine"
Const msSourceCell As String = "F26"
Const msTargetSheet As String = "Sheet2"
Dim moDataDictionary As Object

Sub ExtractData()
Dim lFolderPtr As Long

Set moDataDictionary = Nothing
Set moDataDictionary = CreateObject("Scripting.Dictionary")

' Open the file dialog & prompt for appropriate folder
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = True
    .Show
    If .SelectedItems.Count > 0 Then
        For lFolderPtr = 1 To .SelectedItems.Count
            ProcessFolder CStr(.SelectedItems(lFolderPtr))
        Next lFolderPtr
    Else
        MsgBox "Macro abandoned"
    End If
End With

End Sub
        
Private Sub ProcessFolder(ByVal Folder As String)
Dim FSO As Object, fsoFolder As Object, fsoFC As Object, fsoFL As Object
Dim iShiftPtr As Integer
Dim lFileCount As Long, lCurFile As Long, lReportInterval As Long
Dim lPtr1 As Long, lPtr2 As Long
Dim sCurfile As String, sKey As String
Dim vaData() As Variant
Dim vaDataKeys As Variant
Dim wbCur As Workbook

Set FSO = Nothing
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoFolder = FSO.GetFolder(Folder)
Set fsoFC = fsoFolder.Files
lFileCount = fsoFolder.Files.Count
lCurFile = 0
lReportInterval = 1
For Each fsoFL In fsoFC
    lCurFile = lCurFile + 1
    sCurfile = CStr(fsoFL.Name)
    lReportInterval = lReportInterval - 1
    If lReportInterval < 1 Then
        lReportInterval = 10
        With Application
            .ScreenUpdating = True
            .StatusBar = "Processing file " & lCurFile & " of " & lFileCount & ": " & sCurfile
            .ScreenUpdating = False
        End With
    End If
    
    '-- Check filename is format '999999_M.xls' or '999999_N.xls' --
    If Len(sCurfile) = 12 Then
        Select Case LCase$(Right$(sCurfile, 6))
        Case "_m.xls"
            iShiftPtr = 2
        Case "_n.xls"
            iShiftPtr = 3
        Case Else
            iShiftPtr = 0
        End Select
        If iShiftPtr <> 0 Then
            sKey = Left$(sCurfile, 6)
            If IsNumeric(sKey) Then
                If moDataDictionary.exists(sKey) Then
                    vaData = moDataDictionary.Item(sKey)
                    moDataDictionary.Remove key:=sKey
                Else
                    ReDim vaData(1 To 1, 1 To 3)
                    vaData(1, 1) = Left$(sKey, 6)
                End If
                
                Application.EnableEvents = False
                Set wbCur = Workbooks.Open(FileName:=Folder & Application.PathSeparator & sCurfile, _
                                         ReadOnly:=True)
                On Error Resume Next
                vaData(1, iShiftPtr) = wbCur.Sheets(msSourceSheet).Range(msSourceCell).Value
                wbCur.Close savechanges:=False
                Application.EnableEvents = True
                moDataDictionary.Add key:=sKey, Item:=vaData
            End If
        End If
    End If
Next fsoFL

vaDataKeys = moDataDictionary.keys
'-- Sort the entries --
For lPtr1 = 0 To UBound(vaDataKeys) - 1
    For lPtr2 = lPtr1 + 1 To UBound(vaDataKeys)
        sKey = vaDataKeys(lPtr2)
        If vaDataKeys(lPtr1) > sKey Then
            vaDataKeys(lPtr2) = vaDataKeys(lPtr1)
            vaDataKeys(lPtr1) = sKey
        End If
    Next lPtr2
Next lPtr1

ReDim vaData(1 To 1, 1 To 3)
vaData(1, 1) = "Date"
vaData(1, 2) = "Morning"
vaData(1, 3) = "Night"

With ThisWorkbook.Sheets(msTargetSheet)
    .UsedRange.ClearContents
    .Range("A1:C1").Value = vaData
    For lPtr1 = 0 To UBound(vaDataKeys)
        ReDim vaData(1 To 1, 1 To 3)
        vaData = moDataDictionary.Item(vaDataKeys(lPtr1))
        lPtr2 = lPtr1 + 2
        .Range("A" & lPtr2 & ":C" & lPtr2).Value = vaData
    Next lPtr1
End With

moDataDictionary.RemoveAll
Set moDataDictionary = Nothing

Application.StatusBar = False

End Sub