Skrive data i et andet ark via makro

Jeg har en makro som kan åbne en masse forskellige regneark og hente data fra celler som jeg har valgt den skal hente fra.

Jeg kunne godt tænke mig at lave denne makro til at den overføre data til de regneark den åbner i stedet for at hente data fra dem, som den gør nu.


Min kode ser ud som følgende:

Option Explicit
Dim oFs As New FileSystemObject
Dim oFile As file
Dim oSub, oFolder As folder
Const inkluder As Boolean = True

      Const sDir As String = "F:\"
      Const sText As String = "Afd* - Årsregnskab 2015.xls*"
      Const sFolder As String = "*Regnskab"
      Const tmpWbhandle As Boolean = True
     
      Dim Chk As Boolean
      Dim curWb, tmpWb As Workbook
      Dim curWs As Worksheet
      Dim i, o, f As Integer
      Dim fSize As Long


Sub søgerutine()

Worksheets("Ark1").Activate
Cells.ClearContents
Range("A3").Select
ActiveCell.Offset(0, 0) = "Filnavn(Link)"
ActiveCell.Offset(0, 1) = "Filens path"
ActiveCell.Offset(0, 2) = "Fil Senest ændret"
ActiveCell.Offset(0, 3) = "Afdelings nr"
ActiveCell.Offset(0, 4) = "Boliger i alt"
ActiveCell.Offset(0, 5) = "Afdelingen i alt"


Dim svar As Integer
i = 3
o = 0
f = 0

      Application.Calculation = xlCalculationManual
      Application.Application.ScreenUpdating = False
      Application.Application.DisplayAlerts = False
      Application.Application.EnableEvents = False ' skjuler msbboxe der popper op
 
Call findFiler(sDir, inkluder)
 
      Application.Calculation = xlCalculationAutomatic
      Application.Application.ScreenUpdating = True
      Application.Application.DisplayAlerts = True
      Application.Application.EnableEvents = True ' skjuler msbboxe der popper op
 
i = i - 3


svar = MsgBox(f & " Mapper gennemsøgt " & vbNewLine & i & " Filer fundet" & vbNewLine & o & " Excelfiler behandlet", vbInformation, sDir & " er scannet")

End Sub

Function findFiler(sDir, inkluder)

Set curWb = ActiveWorkbook
Set curWs = ActiveSheet

Set oFs = New FileSystemObject
Set oFolder = oFs.GetFolder(sDir)

On Error Resume Next

If Not LCase(oFolder.Name) Like LCase(sFolder) Then GoTo skipNextFolder
For Each oFile In oFolder.Files

If curWb.Name = oFile.Name Then GoTo skipNext
If Not LCase(oFile.Name) Like LCase(sText) Then GoTo skipNext

      i = i + 1
      ActiveSheet.Hyperlinks.Add Anchor:=curWs.Cells(i, 1), Address:=oFile, TextToDisplay:=oFile.Name
      curWs.Cells(i, 2) = oFolder.Path
      curWs.Cells(i, 3) = oFile.DateLastModified
     
     
If tmpWbhandle = True Then

      If Right(oFile.Name, 4) = ".xls" Or Right(oFile.Name, 5) = ".xlsx" Or Right(oFile.Name, 5) = ".xlsm" Then Chk = True
      If Chk <> True Then GoTo skipNext      ' åbner kun excelfiler
     
      Set tmpWb = Application.Workbooks.Open(oFile)
      o = o + 1


      curWs.Cells(i, 4) = tmpWb.Worksheets("UsdInfo").Range("B5")
      curWs.Cells(i, 5) = tmpWb.Worksheets("Forside").Range("I54")
      curWs.Cells(i, 6) = tmpWb.Worksheets("Forside").Range("I61")
   
     
      tmpWb.Close SaveChanges:=False ' lukker filen uden at gemme
      Chk = False
End If
     
ActiveCell.Offset(1, 0).Select

skipNext:
Next ' hopper til næste fil

skipNextFolder:
If inkluder Then
  For Each oSub In oFolder.SubFolders
      f = f + 1
      Call findFiler(oSub.Path, True)
  Next ' oSub = næste subfolder

End If


End Function


Håber der er nogen som kan hjælpe mig med hvordan man få den til at gøre det modsatte af hvad den gør nu

Mvh
Mads