Hent oplysninger fra diverse ark

Det kommer meget an paa hvad "oplysninger" er. Har disse data en fast struktu i hver eneste ark der skal importeres eller hentes fra?

Ja.. det er samme felt i alle ark.

felter...

Der skal altså hentes data fra ET BESTEMT felt i alle faner i alle filer i EN BESTEMT mappe.

Hvor skal de mange hundrede data så gemmes? I ET felt? I ET felt for hver fil? I ET felt for hver fil og for hver fane? Eller skal de summeres og gemmes i ET felt?

se evt http://www.eksperten.dk/spm/279147

eller http://www.eksperten.dk/spm/333245

Til sjap: der skal hentes data fra to forskellige felter (kan måske blive flere) i hvert regneark i en bestemt mappe.

Dataene skal gemmes i et regneark - 1 række er lige med data fra et ark.

Eksempel: der er hentet fra filen "TKL" fra felt AI værdien 111 og AJ værdien KLO. og fra filen "TKK" fra felt AI værdien 121 og AJ værdien KLOK.

Dette overføres så i det samlede regneark til:
TKL;111;KLO
TKK;121;KLOK

Dvs. en ny række for hver hentet fil.


Det er nøjagtig som der står i den bak foreslår.. jeg må lige se den igennem.. og se om jeg kan finde rede på det. Vender tilbage imorgen tidlig.

Pt bruger jeg denne som virker perfekt. Dog skal der ændres en ting... den spørger om den skal opdatere de kædede data hver gang den åbner et nyt regneark..det skal den bare sige ja til.

Findes der evt. en løsning hvor den ikke skal åbne alle ark?

Public Sub GetDataFromOtherWorkbook()
    Dim sFolder As String
    Dim sFileToOpen() As String
    Dim wbData As Workbook
    Dim rInsert As Range
    Dim lCount As Long

    Application.ScreenUpdating = False
    Set rInsert = Sheets("Ark1").Range("A1")
    sFolder = "F:\Jesper\Kalkulationer\Kalk 2004\"
   
    lCount = 1
    ReDim sFileToOpen(1 To lCount)
    sFileToOpen(lCount) = Dir(sFolder + "*.xls")
    Do While Not (sFileToOpen(lCount) = "")
        lCount = lCount + 1
        ReDim Preserve sFileToOpen(1 To lCount)
        sFileToOpen(lCount) = Dir
    Loop
    ReDim Preserve sFileToOpen(1 To lCount - 1)
    For lCount = 1 To UBound(sFileToOpen)
        Set wbData = Application.Workbooks.Open(FileName:=sFolder & sFileToOpen(lCount))
        rInsert.Offset(lCount, 0).Value = wbData.Sheets(1).Range("J1").Value
        rInsert.Offset(lCount, 1).Value = wbData.Sheets(1).Range("B14").Value
        wbData.Close SaveChanges:=False
        Set wbData = Nothing
    Next lCount
   
    ' Clean up
    Set rInsert = Nothing
    Application.ScreenUpdating = True
   
    End Sub

Bak.. jeg har også prøvet din løsning fra spørgsmålet (279147):

Den går dog i stå ved split.. så jeg kan ikke helt se hvad den kan.



Sub GetValuesFromClosedFiles()
Dim FS As FileSearch
Dim FilePath As String
Dim i As Integer, j As Integer
Dim v As Variant
Dim Cells2Get()
Const Filespec = "*.xls"              'udfyldes af bruger Filtype
Const sheet = "Sheet1"                'udfyldes af bruger Arknavn

FilePath = "C:\test\"                'udfyldes af bruger Startfolder
Cells2Get = Array("A1", "B1", "C1")  'udfyldes af bruger Celler, der skal hentes
Application.ScreenUpdating = False
Set FS = Application.FileSearch
With FS
  .LookIn = FilePath
  .Filename = Filespec
  '.SearchSubFolders = True          'skal underfoldere også søges
  .Execute
  If .FoundFiles.Count = 0 Then
      MsgBox ("Ingen filer fundet")
      Exit Sub
  End If
  For i = 1 To .FoundFiles.Count
    v = Split(.FoundFiles(i), Application.PathSeparator)
    FilePath = Left(.FoundFiles(i), InStrRev(.FoundFiles(i), Application.PathSeparator))
    ActiveCell.Offset(i - 1, 0) = FilePath & v(UBound(v))
    For j = 0 To UBound(Cells2Get)
      ActiveCell.Offset(i - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
  Next
End With
Application.ScreenUpdating = False
End Sub

Private Function GetValue(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(range_ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function

Vedr. dit kodeeksempel fra 29/09-2004 09:10:22

Prøv med

Application.DisplayAlerts = False

Efter dine Dim sætninger. Og i din "Clean up" sætter du så

Application.DisplayAlerts = True

Alternativt kan du på de samme placeringer prøve med

On Error resume Next

og

On Error Goto 0

Hvor vil du sætte false?
jeg har sat den ind øverst.. og den spørger stadig.. "om jeg vil opdatere de kædede data.."

Måske kan du klare det via en indstilling i menuen Funktioner/Indstillinger under fanebladet Rediger kan du fjerne fluebenet i "Spørg, om kæder skal opdateres automatisk"

Kommer det så til at gælde for alle min regneark?

Kan denne kommando ikke bruges?

UpdateLinks:=3

Umiddelbart jo. Men du spørger vel fordi du har prøvet uden at få det ønskede resultat.

Ved bare ikke hvor den skal indsættes i koden...

Public Sub LOTUSGetDataFromOtherWorkbook()

   
    Dim sFolder As String
    Dim sFileToOpen() As String
    Dim wbData As Workbook
    Dim rInsert As Range
    Dim lCount As Long
   

    Application.ScreenUpdating = False
    Set rInsert = Sheets("Ark1").Range("A1")
    sFolder = "F:\Jesper\Kalkulationer\Kalk 2004\"
   
    lCount = 1
    ReDim sFileToOpen(1 To lCount)
    sFileToOpen(lCount) = Dir(sFolder + "*.xls")
    Do While Not (sFileToOpen(lCount) = "")
        lCount = lCount + 1
        ReDim Preserve sFileToOpen(1 To lCount)
        sFileToOpen(lCount) = Dir
    Loop
    ReDim Preserve sFileToOpen(1 To lCount - 1)
    For lCount = 1 To UBound(sFileToOpen)
        Set wbData = Application.Workbooks.Open(FileName:=sFolder & sFileToOpen(lCount))
        rInsert.Offset(lCount, 0).Value = wbData.Sheets(1).Range("J1").Value
        rInsert.Offset(lCount, 1).Value = wbData.Sheets(1).Range("A14").Value
        rInsert.Offset(lCount, 2).Value = wbData.Sheets(1).Range("B14").Value
        rInsert.Offset(lCount, 3).Value = wbData.Sheets(1).Range("F14").Value
        rInsert.Offset(lCount, 4).Value = wbData.Sheets(1).Range("G14").Value
        rInsert.Offset(lCount, 5).Value = wbData.Sheets(1).Range("H14").Value
        rInsert.Offset(lCount, 6).Value = wbData.Sheets(1).Range("J14").Value
        rInsert.Offset(lCount, 7).Value = wbData.Sheets(1).Range("A15").Value
        rInsert.Offset(lCount, 8).Value = wbData.Sheets(1).Range("B15").Value
        rInsert.Offset(lCount, 9).Value = wbData.Sheets(1).Range("F15").Value
        rInsert.Offset(lCount, 10).Value = wbData.Sheets(1).Range("G15").Value
        rInsert.Offset(lCount, 11).Value = wbData.Sheets(1).Range("H15").Value
        rInsert.Offset(lCount, 12).Value = wbData.Sheets(1).Range("J15").Value
        rInsert.Offset(lCount, 13).Value = wbData.Sheets(1).Range("A16").Value
        rInsert.Offset(lCount, 14).Value = wbData.Sheets(1).Range("B16").Value
        rInsert.Offset(lCount, 15).Value = wbData.Sheets(1).Range("F16").Value
        rInsert.Offset(lCount, 16).Value = wbData.Sheets(1).Range("G16").Value
        rInsert.Offset(lCount, 17).Value = wbData.Sheets(1).Range("H16").Value
        rInsert.Offset(lCount, 18).Value = wbData.Sheets(1).Range("J16").Value
        rInsert.Offset(lCount, 19).Value = wbData.Sheets(1).Range("A17").Value
        rInsert.Offset(lCount, 20).Value = wbData.Sheets(1).Range("B17").Value
        rInsert.Offset(lCount, 21).Value = wbData.Sheets(1).Range("F17").Value
        rInsert.Offset(lCount, 22).Value = wbData.Sheets(1).Range("G17").Value
        rInsert.Offset(lCount, 23).Value = wbData.Sheets(1).Range("H17").Value
        rInsert.Offset(lCount, 24).Value = wbData.Sheets(1).Range("J17").Value
        wbData.Close SaveChanges:=False
        Set wbData = Nothing
    Next lCount
   
    ' Clean up
    Set rInsert = Nothing
    Application.ScreenUpdating = True
   
       
    End Sub

Set wbData = Application.Workbooks.Open(FileName:=sFolder & sFileToOpen(lCount), UpdateLinks:=3)

Perfekt ;-) tak skal du have.. og du har jo fået points..

De points der er i denne tråd.. vil jeg gerne give til bak.. hvis han vil svare..

Fint. Det var jo heldigt, at jeg kunne hjælpe, når jeg allerede har fået pointene :0)

ja...

Lige en ting mht. min kode.
Den er kun beregnet til xl2000 eller højere. Split findes ikke i xl97 :-)

Så er det derfor det ikke virker...