Avatar billede larsv Nybegynder
20. oktober 2013 - 17:28 Der er 6 kommentarer

Hente data fra flere forskellige regneark til et samleark

Hej..

Jeg håber nogen kan hjælpe mig med denne lille sag:

- Ca. 30 Excel-ark liggende i samme mappe.
- Excel 2013
- Skal lave et opsamlingsregneark, som kan hente data fra de 30  forskellige regneark.
- De 30 regneark har ca. 30 "ark" hver, men er ellers ens. Dvs den nødvendige data er i samme ark og felt i alle 30 ark.
- Antallet af regneark svinger lidt

Jeg har kigget og netop forsøgt mig med denne:
http://www.eksperten.dk/spm/922120

Jeg bruger Excel 2013 og her virker det som om, at funktionen  Application.FileSearch ikke længere virker.

Er der nogen der har et bud på, hvad jeg så skal bruge?

Hilsen fra Lars
Avatar billede kabbak Professor
21. oktober 2013 - 13:52 #1
Åben en ny tom mappe.

Indsæt et modul i VBA og sæt denne kode derind.

Public Sub SamleData()
  Dim Fil As Variant, WS As Worksheet, Navn As String, Rk As Long, Overskrift As Boolean
  Dim SkrivOverskrift As Variant, Kol As Long
  Overskrift = False
ChDir ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        ReDim Fil(.SelectedItems.Count)
        For I = 1 To .SelectedItems.Count
        Fil(I) = .SelectedItems(I)
        Next
    End With
svar = MsgBox(" er der overskrifter i række 1 ", vbYesNo)
If svar = vbYes Then
Overskrift = True
End If

    For I = 1 To UBound(Fil)
  Workbooks.Open (Fil(I))
For Each WS In ActiveWorkbook.Sheets
Navn = WS.Name
WS.Activate
    If Overskrift Then
    Kol = ActiveSheet.UsedRange.Columns.Count
        SkrivOverskrift = Range(Cells(1, "A"), Cells(1, Kol))
        Data = Range(Range("A2"), Range("A2").SpecialCells(xlLastCell))
    Else
        Data = Range(Range("A1"), Range("A2").SpecialCells(xlLastCell))
    End If
 
Call SheetsExist(Navn) ' er siden oprettet, ellers bliver den det
With ThisWorkbook
Rk = .Worksheets(WS.Name).UsedRange.Rows.Count
    If .Worksheets(WS.Name).Range("A1") = "" Then
        .Worksheets(WS.Name).Cells(1, 1).Resize(UBound(SkrivOverskrift, 1), UBound(SkrivOverskrift, 2)) = SkrivOverskrift
    End If
.Worksheets(WS.Name).Cells(Rk + 1, 1).Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End With
Next
For Each Wb In Workbooks
If Wb.Name <> ThisWorkbook.Name Then
Wb.Close SaveChanges:=False
End If
Next
    Next

   
End Sub

Public Sub SheetsExist(Navn)
Dim WS As Worksheet
With ThisWorkbook
For Each WS In .Sheets
If WS.Name = Navn Then
.Worksheets(WS.Name).Activate
Exit Sub
End If
Next
.Worksheets.Add    ' opretter nyt ark
  .ActiveSheet.Name = Navn  ' Navngiver arket
  End With
End Sub
Avatar billede finb Ekspert
21. oktober 2013 - 16:12 #2
Har du prøvet Excel´s
Konsolidering ?
Avatar billede larsv Nybegynder
15. november 2013 - 15:04 #3
Jeg kan ikke finde ud af, hvad denne kode gør. Egentlig skal jeg blot have løst mit problem med at Application.FileSearch ikke virker i 2013. Løser koden det problem?
Avatar billede Sitestory Mester
15. november 2013 - 17:45 #4
FileSearch forsvandt med Excel 2007. Du skal bruge FileSystemObject.
Se: http://msdn.microsoft.com/en-us/library/office/jj229903.aspx
og: http://msdn.microsoft.com/en-us/library/office/gg278516.aspx for eksempel.
Avatar billede larsv Nybegynder
16. november 2013 - 08:15 #5
Tak. Så langt så godt. Ergo skal jeg have lavet min kode om, så den kan finde filerne. Problemet er, at jeg ikke er en haj til VBA kode, så jeg ved ikke, hvordan jeg bruger den nye kommando. Er der en af jer hajer, så nemt kan skrive de linier jeg skal bruge i stedet for den gamle funktion?
Avatar billede Sitestory Mester
16. november 2013 - 09:41 #6
Det er jo en kende vanskeligt, når man ikke kender din gamle funktion, men der findes søgemaskiner, som kan lede en på sporet af, hvordan man gør - fx hertil:
http://www.xl-central.com/list-files-fso.html
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