Hente værdier fra forskellige excel filer til et ark.

Jeg laver en lille test i aften og smider et forslag.

Kom nedenstående ind i et modul

Det burde virke, men det kan være, at der er behov for lidt tilretninger.


Option Explicit

Function GetValuesFromExcelsheets()
Dim Path As String
  Path = "C:\Documents and Settings\krist24j\My Documents\Yaw\Test DB\Export\11-04-2011\"
Dim z As Integer, interval As Integer
  z = 1: interval = 100
Dim aWB() As Variant
  ReDim aWB(1 To 4, 1 To z * interval) As Variant
Dim rec As Integer
Dim temparr() As Variant
  rec = LBound(aWB, 1) - 1
Dim s As String
Dim a As Integer, b As Integer
Dim Workbook
  Set Workbook = CreateObject("Excel.application")
 
' Få første filnavn
  s = Dir(Path)
  If Right(s, 4) = "XLSX" Then ' (Ret til Right(s, 3) = "XLS", hvis det er ældre filer end 2007)
    rec = rec + 1
    aWB(rec) = s
  End If
 
' Få resterende filnavne
  Do While True
    s = Dir
 
  ' Escape loop hvis der ikke er flere filer
    If s = "" Then
      Exit Do
    End If
    If Right(UCase(s), 4) = "XLSX" Then
      rec = rec + 1
  ' Udvider arrayet, hvis man løber tør for plads
      If rec = UBound(aWB, 2) Then
        z = z + 1
        ReDim Preserve aWB(1 To 4, 1 To z * interval) As Variant
      End If
      aWB(1, rec) = s
    End If
  Loop
' Reducer array til aktuelt antal filer
  ReDim Preserve aWB(1 To 4, 1 To rec) As Variant
 
' Læs værdier i filerne  For rec = LBound(aWB, 2) To UBound(aWB, 2) Step 1
    Workbook.Workbooks.Open Path & aWB(1, rec)
    aWB(2, rec) = Workbook.Sheets(1).Cells(174, 5).Value
    aWB(3, rec) = Workbook.Sheets(1).Cells(175, 5).Value
    aWB(4, rec) = Workbook.Sheets(1).Cells(176, 5).Value
  Next rec
 
' Vend Array for en record per række i Excel
  ReDim temparr(LBound(aWB, 2) To UBound(aWB, 2), LBound(aWB, 1) To UBound(aWB, 1)) As Variant
  For a = LBound(aWB, 1) To UBound(aWB, 1) Step 1
    For b = LBound(aWB, 2) To UBound(aWB, 2) Step 1
      temparr(b, a) = aWB(a, b)
    Next b
  Next a
  ' Skriver til aktiv Excelmappe
  Range(Cells(LBound(temparr, 1), LBound(temparr, 2)), Cells(UBound(temparr, 1), UBound(temparr, 2))) = temparr()
 
  Workbook.Quit
  Set Workbook = Nothing
End Function

Åben din Data.xls, tryk Alt + F11 for at komme ind i VBA'en.
Højreklik på mappen i venstre side og vælg Insert module.
Copy paste understående kode ind i det nyoprettede modul.

Koden virker KUN hvis arket hvor værdierne skal lande i Data.xls hedder "Ark1" OG KUN hvis arket, hvor værdierne kommer fra i hedder "Ark1". Resten burde være ligegyldigt.

Jeg har angivet, hvor du kan skrive nye navne hvis arkene ikke hedder "Ark1".

Hvis arket/fanen med E174, E175 og E176 nu hedder noget forskelligt i de mange ark, så må du lige vende tilbage, så vi kan se om vi kan identificere dem på en anden måde. Hvis det er noget DB udtræk, så er der muligvis kun det ene ark og så tager vi dem på index.

Koden:
-------------------------------------------------------

Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim dataSheet As String
Dim resultSheet As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

dataSheet = "Ark1"      'Skriv navnet på arkets/fanens navn i Data.xls
resultSheet = "Ark1"    'Skriv navnet på arkets/fanens navn i de .xls tallene skal trækkes ud af

On Error Resume Next
    Set wbCodeBook = ThisWorkbook
        With Application.FileSearch
            .NewSearch
            'Change path to suit
            .LookIn = ThisWorkbook.Path & "\test" ' 11-04-2011
            .FileType = msoFileTypeExcelWorkbooks
            'Optional filter with wildcard
            '.Filename = "Book*.xls"
                If .Execute > 0 Then 'Workbooks in folder
                    For lCount = 1 To .FoundFiles.Count 'Loop through all
                        'Open Workbook x and Set a Workbook variable to it
                        Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                       
                        ThisWorkbook.Worksheets(dataSheet).Range("A" & lCount + 1) = Left(wbResults.Name, Len(wbResults.Name) - 4)
                        ThisWorkbook.Worksheets(dataSheet).Range("B" & lCount + 1) = wbResults.Worksheets(resultSheet).Range("E174")
                        ThisWorkbook.Worksheets(dataSheet).Range("C" & lCount + 1) = wbResults.Worksheets(resultSheet).Range("E175")
                        ThisWorkbook.Worksheets(dataSheet).Range("D" & lCount + 1) = wbResults.Worksheets(resultSheet).Range("E176")
                       
                        wbResults.Close SaveChanges:=True
                    Next lCount
                End If
        End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

-------------------------------------------------------


Århhhh så kommer der en mens jeg sidder i preview :-D

Tak for svarene. Jeg får først tid til at kikke på det mandag, men det bliver spændende.

Har det iøvrigt noget at sige at det er en DK-version jeg kører? Jeg ved at den ikke kan finde ud af normale engelske formler (if, or, ect), men gælder dette også for VBA delen?

VBA delen er normalt altid på engelsk, så det er ikke være noget problem. Jeg kører selv DK version uden problemer.

Så lige en bug i min kode.

Linjen ' Læs værdier i filerne  For rec = LBound(aWB, 2) To UBound(aWB, 2) Step 1

skal have et linjeskift lide inden "FOR".

Bemærk, at du ved at sætte variablen WorkBook til CreateObject kan læse direkte i filerne uden at åbne dem, og dermed vil koden kører hurtigere igennem end hvis du åbner hver workbook.

Tryphon:
Jeg får en runtime error 9; Subscript out of range på linien:
  ReDim Preserve aWB(1 To 4, 1 To rec) As Variant

iver_mo:
Jeg har indsat din kode som beskrevet og udskiftet navnet på arket med dataene med <resultSheet = "Alle poster uden dubletter">, men jeg synes ikke rigtig der sker noget.
Jeg har indsat koden, gemt den og skiftet til Excel arket.
Når jeg så trykker "run" på arbejdslinien i Excel sker der.....ingen ting.
Jeg har prøvet at lukke arket og åbne det igen uden ændringer.

Hej Bandit

Når den går i fejl, så klik på "debug" og før musen hen over "rec", i den linje, hvor den går i fejl. Hvis der står 0, har du ikke fået fat i nogen af filerne.

Hvilken file extension har du på dine filer. Koden læser på "XLSX", som er 2007 filer.

Hvis det er 2003 filer, skal du ændre koden de to steder, hvor der står " If Right(s, 4) = "XLSX" til "IF Rightx, 3) = "XLS".

Så burde den virke.

Hmm, den brokker sig stadig.

Der står "0" som du siger, også efter jeg har rettet "If Right(s, 4) = "XLSX""  til "If Right(s, 3) = "XLS"".

Efter tilretning ser den ud som følger:

Option Explicit

Function GetValuesFromExcelsheets()
Dim Path As String
  Path = "C:\Documents and Settings\krist24j\My Documents\Yaw\Test DB\Export\11-04-2011\"
Dim z As Integer, interval As Integer
  z = 1: interval = 100
Dim aWB() As Variant
  ReDim aWB(1 To 4, 1 To z * interval) As Variant
Dim rec As Integer
Dim temparr() As Variant
  rec = LBound(aWB, 1) - 1
Dim s As String
Dim a As Integer, b As Integer
Dim Workbook
  Set Workbook = CreateObject("Excel.application")
 
' Få første filnavn
  s = Dir(Path)
  If Right(s, 3) = "XLS" Then ' (Ret til Right(s, 3) = "XLS", hvis det er ældre filer end 2007)
    rec = rec + 1
    aWB(rec) = s
  End If
 
' Få resterende filnavne
  Do While True
    s = Dir
 
  ' Escape loop hvis der ikke er flere filer
    If s = "" Then
      Exit Do
    End If
    If Right(UCase(s), 3) = "XLS" Then
      rec = rec + 1
  ' Udvider arrayet, hvis man løber tør for plads
      If rec = UBound(aWB, 2) Then
        z = z + 1
        ReDim Preserve aWB(1 To 4, 1 To z * interval) As Variant
      End If
      aWB(1, rec) = s
    End If
  Loop
' Reducer array til aktuelt antal filer
  ReDim Preserve aWB(1 To 4, 1 To rec) As Variant
 
' Læs værdier i filerne
    For rec = LBound(aWB, 2) To UBound(aWB, 2) Step 1
    Workbook.Workbooks.Open Path & aWB(1, rec)
    aWB(2, rec) = Workbook.Sheets(1).Cells(174, 5).Value
    aWB(3, rec) = Workbook.Sheets(1).Cells(175, 5).Value
    aWB(4, rec) = Workbook.Sheets(1).Cells(176, 5).Value
  Next rec
 
' Vend Array for en record per række i Excel
  ReDim temparr(LBound(aWB, 2) To UBound(aWB, 2), LBound(aWB, 1) To UBound(aWB, 1)) As Variant
  For a = LBound(aWB, 1) To UBound(aWB, 1) Step 1
    For b = LBound(aWB, 2) To UBound(aWB, 2) Step 1
      temparr(b, a) = aWB(a, b)
    Next b
  Next a
  ' Skriver til aktiv Excelmappe
  Range(Cells(LBound(temparr, 1), LBound(temparr, 2)), Cells(UBound(temparr, 1), UBound(temparr, 2))) = temparr()
 
  Workbook.Quit
  Set Workbook = Nothing
End Function

Når rec = 0 er det fordi, den ikke finder match på søgekriteriet xls.

Prøv at rette Right(s, 3) = "XLS" til Ucase(Right(s, 3)) = "XLS". Det kan være, at den læser case sensitive.

Kan du give et eksempel på et filnavn, du forsøger at læse fra? Inklusive file extension.

Prøv evt. at køre koden igennem med F8. Så kører du step by step. Læg mærke til, hvad værdien for s bliver. Måske bliver du klogere den vej. I VBA modulet kan du aktivere Debug værktøjslinjen og vælge Locals Window. Så har du overblik over variablerne og værdierne.

Efter at have rettet "Right(s, 3)" til "Ucase(Right(s, 3))" et enkelt sted, kommer der nu en "Subscript out of range (Error 9)" på linien <aWB(rec) = s>

rec = 1
s = V302368M3N25422524.xls, som er et af filnavnene.

Et eksempel på filnavn + sti kunne være:
C:\Documents and Settings\krist24j\My Documents\Yaw\Test DB\Export\11-04-2011\V302368M3N25422524.xls
Arket i filen hedder "Alle poster uden dubletter"

Jeg kan køre koden igennem indtil fejlen, men jeg ved ikke rigtigt, hvad det er jeg kikker efter.

Mailer du mig lige filen med din kode i. jc@3xchristensen.dk.

Så kigger jeg på den i morgen tidlig.

Tryphon> Er der noget nyt om koden?
Jeg sendte arket til dig sidste tirsdag - har du modtaget det?

Hej Bandit

Jeg mailede dig en testet kode retur samme dag fra min arbejdsmail incl. en feature, der sletter eksisterende, inden koden skriver tilbage.

Ret linjen <aWB(rec) = s> til <aWB(1, rec) = s>. Så burde den virke.

Hvis du har flere spørgsmål, kan du så ikke bruge mail, hvis du vil have hurtigt svar. Jeg holder ferie i denne uge og er ikke så meget på computeren.

Hej Bandit

Jeg har ændret en enkelt linje og mailet den til dig. Hvis der er noget, der går galt med mail, har du den endelige kode her.

Function GetValuesFromExcelsheets()
Dim Path As String
  Path = "C:\Documents and Settings\krist24j\My Documents\Yaw\Test DB\Export\11-04-2011\"
Dim z As Integer, interval As Integer
  z = 1: interval = 100
Dim aWB() As Variant
  ReDim aWB(1 To 4, 1 To z * interval) As Variant
Dim rec As Integer
Dim temparr() As Variant
  rec = LBound(aWB, 1) - 1
Dim s As String
Dim a As Integer, b As Integer
Dim Workbook
  Set Workbook = CreateObject("Excel.application")
 
' Få første filnavn
  s = Dir(Path)
  If UCase(Right(s, 3)) = "XLS" Then ' (Ret til Right(s, 3) = "XLS", hvis det er ældre filer end 2007)
    rec = rec + 1
    aWB(1, rec) = s
  End If
 
' Få resterende filnavne
  Do While True
    s = Dir
 
  ' Escape loop hvis der ikke er flere filer
    If s = "" Then
      Exit Do
    End If
    If Right(UCase(s), 3) = "XLS" Then
      rec = rec + 1
  ' Udvider arrayet, hvis man løber tør for plads
      If rec = UBound(aWB, 2) Then
        z = z + 1
        ReDim Preserve aWB(1 To 4, 1 To z * interval) As Variant
      End If
      aWB(1, rec) = s
    End If
  Loop
' Reducer array til aktuelt antal filer
  ReDim Preserve aWB(1 To 4, 1 To rec) As Variant
 
' Læs værdier i filerne
  For rec = LBound(aWB, 2) To UBound(aWB, 2) Step 1
    Application.StatusBar = "Reading file " & rec & " of " & UBound(aWB, 2)
    Workbook.Workbooks.Open Path & aWB(1, rec)
    aWB(2, rec) = Workbook.Sheets(1).Cells(174, 5).Value
    aWB(3, rec) = Workbook.Sheets(1).Cells(175, 5).Value
    aWB(4, rec) = Workbook.Sheets(1).Cells(176, 5).Value
    Workbook.ActiveWorkbook.Close False
  Next rec
  Application.StatusBar = False
' Vend Array for en record per række i Excel
  ReDim temparr(LBound(aWB, 2) To UBound(aWB, 2), LBound(aWB, 1) To UBound(aWB, 1)) As Variant
  For a = LBound(aWB, 1) To UBound(aWB, 1) Step 1
    For b = LBound(aWB, 2) To UBound(aWB, 2) Step 1
      temparr(b, a) = aWB(a, b)
    Next b
  Next a
  ' Skriver til aktiv Excelmappe
  Range(Cells(LBound(temparr, 1) + 2, LBound(temparr, 2)), Cells(UBound(temparr, 1) + 2, UBound(temparr, 2))) = temparr()
 
  Workbook.Quit
  Set Workbook = Nothing
End Function

Så kører det.
Tak for hjælpen :-)