Cargar Matriz en Excel con VBA

Buenas como estan,

mire tengo u gran problema en Excel con VBA tengo este codigo, y deseo simplificarlo y corregir el error de que no me carga bien la matriz en la hoja llamada General, que podre hacer, en negrita es donde esta la simplificacion y error:

Public NuevoNombre As String

Sub CopiarHojaDeArchivosEnDirectorio()

  Dim Ruta As String, Archivo As String

    Application.ScreenUpdating = False

    With ThisWorkbook

      Ruta = .Path & ""

      Archivo = Dir(Ruta & "*.xls*")

      Do While Archivo <> ""

        If Archivo = .Name Then GoTo Siguiente

        Application.StatusBar = "Procesando..." & Archivo

        Workbooks.Open Ruta & Archivo

        Worksheets(3).Copy After:=.Worksheets(.Worksheets.Count)

        CambiaNombre (Archivo)

        .Worksheets(.Worksheets.Count).Name = NuevoNombre

        For C = 3 To 49

            For A = 5 To 40

                .Worksheets(.Worksheets.Count).Activate

        '                Asigna valor de fila G + valor(A) en Dato

                Dato = Worksheets(.Worksheets.Count).Cells(A, 7).Value

                Porciento = Worksheets(.Worksheets.Count).Cells(1, 8).Value

                Programa1 = Worksheets(.Worksheets.Count).Cells(5, 2).Value                Programa2 = Worksheets(.Worksheets.Count).Cells(8, 2).Value                Programa3 = Worksheets(.Worksheets.Count).Cells(13, 2).Value                Programa4 = Worksheets(.Worksheets.Count).Cells(18, 2).Value                Programa5 = Worksheets(.Worksheets.Count).Cells(21, 2).Value                Programa6 = Worksheets(.Worksheets.Count).Cells(25, 2).Value                Programa7 = Worksheets(.Worksheets.Count).Cells(32, 2).Value                Programa8 = Worksheets(.Worksheets.Count).Cells(37, 2).Value                Programa9 = Worksheets(.Worksheets.Count).Cells(39, 2).Value                Windows("Consolida.xlsm").Activate                Worksheets(2).Cells(.Worksheets.Count, 4).Value = Programa1                Worksheets(2).Cells(.Worksheets.Count, 8).Value = Programa2                Worksheets(2).Cells(.Worksheets.Count, 14).Value = Programa3                Worksheets(2).Cells(.Worksheets.Count, 20).Value = Programa4                Worksheets(2).Cells(.Worksheets.Count, 24).Value = Programa5                Worksheets(2).Cells(.Worksheets.Count, 29).Value = Programa6                Worksheets(2).Cells(.Worksheets.Count, 38).Value = Programa7                Worksheets(2).Cells(.Worksheets.Count, 44).Value = Programa8                Worksheets(2).Cells(.Worksheets.Count, 47).Value = Programa9

B = A - 1                If Worksheets(2).Cells(C, B).Value = "" Then                    If A < 41 Then        '                    Asigna Dato en fla D + valor(C)                        Worksheets(2).Cells(C, B).Value = Dato                    Else                        B = A        '                    Asigna Dato en fla D + valor(C)                        Worksheets(2).Cells(C, B).Value = Dato                    End If                End If                Next A            A = 5        Next C

        Windows("Consolida.xlsm").Activate

        Worksheets(2).Cells(.Worksheets.Count, 2).Value = NuevoNombre

        Worksheets(2).Cells(.Worksheets.Count, 3).Value = Porciento

        Workbooks(Archivo).Close False

Siguiente:

            Archivo = Dir()

          Loop

        End With

        Application.StatusBar = "Listo"

End Sub

Public Function CambiaNombre(cadena As String) As String

Dim Posicion As Integer, Caracter As Variant

'definimos una matriz sin especificar elementos

Dim Matr() As Variant

'la redefinimos y le asignamos un número de elementos

'igual al número de caracteres que componen la cadena a evaluar

ReDim Preserve Matr(Len(cadena))

'recorremos cada uno de dichos caracteres

For Posicion = 1 To Len(cadena)

    Caracter = Mid$(cadena, Posicion, 1)

    If Caracter <> " " Then

        Matr(Posicion) = Caracter

        NuevoNombre = Join(Matr, "")

    Else

        Exit For

    End If

    Next Posicion

End Function