Tilføjelse til eksisterende VBA kode

Hej eksperter

Jeg bruger Excel 2010, engelsk version.

Jeg har en eksisterende VBA kode som jeg gerne vil have tilføjet noget til, men jeg er ikke garvet nok til selv at kunne klarer det, så jeg håber at I kan hjælpe mig.

Hvis jeg med ord skal forklarer det, så har jeg en VBA kode som åbner en masse filer (kildefiler) placeret i en og samme folder. I hver af kildefilerne kopieres et range og det indsættes herefter løbende efter hinanden i en blank fil (destinationsfil).

Jeg vil nu gerne have tilføjet en process INDEN ranget kopieres fra kildefilerne. Tilføjelsen lyder således:
1. kopier celle 'CONSOLIDATE DATA'!D3 i destinationsfilen.
2. indsæt den kopierede celle som værdi i celle 'Working Sheet'!D8
3. Beregn formler (knappen hedder "Calculate now" i min excel)


Jeg har kopieret koden ind herunder:


Sub OpenAll()
'On Error Resume Next
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With


Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strpath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
getfolder = sItem
Set fldr = Nothing
    Dim strFileName As String
    strFileName = Dir(getfolder & "\*.xls*")
    Do
        If Len(strFileName) <> 0 And strFileName <> ThisWorkbook.Name Then
            Workbooks.Open Filename:=getfolder & "\" & strFileName, UpdateLinks:=0
     
       
       
        openwkb = Workbooks(strFileName).Name 'ActiveWorkbook.Name

        'DO YOUR CODE HERE
        For Each sht In Workbooks(openwkb).Worksheets
        For Each cell In ThisWorkbook.Worksheets("CONSOLIDATE DATA").Range("A2:A10")
                    If cell.Value = "" Then Exit For
                    If sht.Name = cell.Value Then
                        a = cell.Offset(0, 1).Text
                        Workbooks(openwkb).Sheets(sht.Name).Range(a).Copy
                        endrow = ThisWorkbook.Sheets(sht.Name).Range("A1048576").End(xlUp).Row
                        If endrow = 1 Then endrow = 0
                        ThisWorkbook.Sheets(sht.Name).Cells(endrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Application.CutCopyMode = False
                    End If
        Next cell
        Next sht
       
        Workbooks(openwkb).Close
       
       
    End If
    strFileName = Dir
    Loop Until Len(strFileName) = 0
ending:
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculate
.Calculation = xlCalculationAutomatic
End With


End Sub


Er der nogen der kan hjælpe med at lave tilføjelsen, og indsætte den det rigtige sted?

Mvh
Line