parse_files_com

Function onlyDigits(s As String) As String
    ' Variables needed (remember to use "option explicit").   '
    Dim retval As String    ' This is the return string.      '
    Dim i As Integer        ' Counter for character position. '

    ' Initialise return string to empty                       '
    retval = ""

    ' For every character in input string, copy digits to     '
    '   return string.                                        '
    For i = 1 To Len(s)
        If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
            retval = retval + Mid(s, i, 1)
        End If
    Next

    ' Then return the return string.                          '
    onlyDigits = retval
End Function

Sub test_macros_parse()
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    sFilePath = "path"

    k = 7   'get max num of years
    a = 4   ' index using to start writing datas

     If Right(sFilePath, 1) <> "\" Then
        sFilePath = sFilePath & "\"
    End If

    sFileName = Dir(sFilePath & "*.xls")


    Workbooks.Open Filename:=sFilePath & sFileName

    Debug.Print (sFileName)

     Do While Len(sFileName) > 0
        If Right(sFileName, 4) = "xls" Then

            Workbooks.Open Filename:=sFilePath & sFileName
            Do
                'Debug.Print (Workbooks(sFileName).Sheets("sheet").Cells(7, k).Value)
                For i = 8 To 202

                    If Workbooks(sFileName).Sheets("sheet").Cells(i, 4).Interior.Color = 6724095 Then

                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 1).Value = sFileName
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 4).Value = Workbooks(sFileName).Sheets("sheet").Cells(1, k).Value
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 3).Value = Workbooks(sFileName).Sheets("sheet").Cells(1, 3).Value
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 6).Value = Workbooks(sFileName).Sheets("sheet").Cells(i, k).Value
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 7).Value = Workbooks(sFileName).Sheets("sheet").Cells(i, 4).Value
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 5).Value = Workbooks(sFileName).Sheets("sheet").Cells(4, k).Value
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 9).Value = k
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 8).Value = i
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 10).Value = onlyDigits(Workbooks(sFileName).Sheets("sheet").Cells(2, 1).Value)
                            ThisWorkbook.Sheets("Ëèñò1").Cells(a, 11).Value = Workbooks(sFileName).Sheets("sheet_1").Cells(5, 4).Value

                            'Debug.Print (Workbooks(sFileName).Sheets("sheet").Cells(2, 1).Value)
                            'Debug.Print (Workbooks(sFileName).Sheets("sheet").Cells(5, 4).Value)
                            'Debug.Print (Workbooks(sFileName).Sheets("sheet").Cells(4, k).Value)

                            a = a + 1
                    End If

                Next i
                k = k + 1
            Loop While Workbooks(sFileName).Sheets("sheet").Cells(7, k).Value <> ""



            Workbooks(sFileName).Close
        End If

         k = 7
         sFileName = Dir
    Loop
    Application.ScreenUpdating = True
    Application.EnableEvents = True


End Sub