Avatar billede MadsP007 Novice
21. januar 2016 - 00:32 Der er 1 løsning

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
Avatar billede MadsP007 Novice
21. januar 2016 - 17:03 #1
Lukker den, har løst problemet
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester