Datatabel linket til mange forskellige filer

Hej Line

Ligger filerne i samme mappe?
Data fra de enkelte filer skal så lægges i forlængelse af hinanden?

Et stk VBA skulle nok klare dette..

Hej Supertekst

Ja de ligger i samme mappe. MEN de gemt på en sharepoint site, så jeg ved ikke om det betyder noget. Men på sharepoint sited kan jeg placere dem i den samme mappe hvis det hjælper på det.

Vil man kunne løse det med filnavne der ikke er fortløbende numre med VBA'en? Og evt. også at det område man skal linke til er flere ikke sammenhængende områder, fx A1:P20 og A25:P30 og A49:P50.

Hvordan vil sådan en VBA fungere når der linkes til andre filer, vil den skulle åbne de andre filer for at det virker, eller køre det bare i baggrunden uden at noget åbnes?

Filnavne: Intet problem når der anvendes udtryk, der behandler alle filer i en mappe. Herved er det heller ikke et problem når der kommer flere kildefiler

Områder: Jeg forestiller mig at kopiere de nævnte områder over i destiantionsfilen og så "stakke" dem - eller?

VBA: vil således hente data fra de enkelte filer - ved at åbne og lukke den enkelte fil som et object, der ikke nødvendigvis er synligt.

Filnavne: super, lyder som en god løsning

Områder: hvis du med stakke mener at område A1:P20 og A25:P30 og A49:P50 kopieres ind i "konsolideringsfilen" så det bliver til område A1:P28 så er vi enige :-)

VBA: jeg kan ikke gennemskue hvad det du skriver betyder. Jeg skal bare være sikker på at det kan lade sig gøre selvom at filerne er gemt på et sharepoint site som er styret med check out/check in funktion.

Hvis vi er enige om ovenstående, så vil jeg meget gerne tage imod tilbuddet om en VBA kode :-)

Kender desværre ikke til "sharepoint og dets væsen" - men vi kan jo starte med en mindre udgave, der kun prøve at traversere gennem filerne.

God ide. Har du brug for noget fra mig?

Nej tak - nu prøver først at kreere modellen og så skal du korrigere stien til den relevante mappe.

Såfremt du allerede har den - så må du godt sende den.

Jeg sender imorgen :-)

Ok..

VBA-kode i ThisWorkbook:

Rem Version 1 17-04-2012
Rem ====================
Dim ræk As Long
Rem Destination
Const destinationsArk = "CC cost,HC,Hours per product"
Const omrDef = "Cost,E2,L1,C7:AB31,C37:AB37;HC,D2,I1,C61:Y64,C69:AB73,C101:AB102;HC,D2,I1,C12:Y31"
Const omrSletKol = "V-W-AB,S-T-Y,S-T-Y"
Dim dArk As Variant, områdeDef As Variant, områdeSlet As Variant
Const destBasisRæk = 2
Dim destRæk(3)

Rem Source
Rem Const mappeMedSalgsFiler = "C:\Users\peter\Desktop\LineRiber_120412\SalgsMappe"                                    'Supertekst
Const mappeMedSalgsFiler = "G:\SCM\MF11 Controlling\Budget FY13\Budget models for Cost and HC\Supertekst1"      'Siemens    <<<<<<<<<<<<<< HUSK >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim omrN As Variant, omr As Variant
Dim arkSamling As Worksheet
Dim rSam As Range
Dim xlsFil As Object
Dim arkSalg As Worksheet
Dim rSalg As Range

Rem Overskrifter
Const overskrifterArkNavn = "Overskrifter"
Dim arkHeader As Worksheet
Public Sub samlingAfFiler()
    Housekeeping
    indsætOverskrifter
    traverserFiler mappeMedSalgsFiler
    udførFinish                                    'sletkolonner og fjern formatering pr. ark
   
    MsgBox "Samling af filer afsluttet"
End Sub
Private Sub Housekeeping()
    Set samFil = ActiveWorkbook
   
    dArk = Split(destinationsArk, ",")
    områdeDef = Split(omrDef, ";")
    områdeSlet = Split(omrSletKol, ",")
   
Rem 1. række i Destination pr. ark
    destRæk(0) = destBasisRæk
    destRæk(1) = destBasisRæk
    destRæk(2) = destBasisRæk
End Sub
Private Sub traverserFiler(mappesti)
Dim fs, f, f1, fc, fNavn As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappesti)
    Set fc = f.Files
    For Each f1 In fc
        fNavn = f1.Name
        hentDataFraFilen mappesti, fNavn
    Next
End Sub
Private Sub hentDataFraFilen(mappesti, filNavn)
Dim sourceArk As String, destArk As String, ræk As Long
Dim dupAdr1 As String, dupAdr22 As String, dupData1 As String, dupData2 As String
On Error GoTo fejl

    Application.ScreenUpdating = False
   
Rem Åbn salgsfilen
    Set xlsFil = CreateObject("Excel.Application")
    With xlsFil
        .Workbooks.Open mappesti & "\" & filNavn

Rem Ved test - kunne se sourcefil
Rem        .Visible = True
   
Rem kopier de enkelte ark fra source til destiantionsfil
        For a = 0 To UBound(dArk)
            arkNavn = dArk(a)
            område = områdeDef(a)
            hentFraArk = Split(område, ",")
            sourceArk = hentFraArk(0)
           
Rem startrække i destinationsark
            ræk = destRæk(a)

            Set arkSamling = ActiveWorkbook.Sheets(arkNavn)
            arkSamling.Activate
       
            omr = Split(område, ",")
            sourceArk = omr(0)
       
            Set arkSalg = xlsFil.ActiveWorkbook.Sheets(sourceArk)
           
Rem dupliceringsfelter til kolonne 1 & 2
            dupAdr1 = omr(1)
            dupAdr2 = omr(2)
           
            dupData1 = arkSalg.Range(dupAdr1)
            dupData2 = arkSalg.Range(dupAdr2)
           
Rem kopier de enkelte områder fra source til destination
            For r = 3 To UBound(omr)
Rem beregn antal rækker
                arkSalg.Activate
               
                rr = ActiveSheet.Range(omr(r)).Rows.Count
               
                With arkSalg
                    .Range(omr(r)).Copy
                End With
               
                arkSamling.Activate
                arkSamling.Range("C" & ræk).Select
               
Rem indsæt i samlefil
                Selection.PasteSpecial Paste:=xlPasteValues
               
                Set rSalg = Nothing
                Set rsamling = Nothing
                ræk = ræk + rr
               
                xlsFil.Application.CutCopyMode = False
            Next r
Rem Indsæt dup-felter i kolonne A & B
            indsætDupFelter destRæk(a), ræk - 1, 1, dupData1
            indsætDupFelter destRæk(a), ræk - 1, 2, dupData2
                   
Rem Opdater destinationsrække for arket
            destRæk(a) = ræk
        Next a
        .Quit
    End With
       
    Set xlsFil = Nothing
    Exit Sub

fejl:
On Error Resume Next
    xlsFil.Quit
    Set xlsFil = Nothing
   
    MsgBox "Fejl erkendt"
   
Rem Tester udgang
    Stop
  Resume Next
End Sub
Private Sub indsætDupFelter(fraRæk, tilRæk, kolonne, data)
Dim ræk As Long
    For ræk = fraRæk To tilRæk
        ActiveSheet.Cells(ræk, kolonne).Select
        Selection.Value = data
    Next ræk
End Sub
Private Sub udførFinish()
Dim a As Integer
    For a = 0 To UBound(dArk)
        ActiveWorkbook.Sheets(dArk(a)).Activate
        sletkolonner områdeSlet(a)
        fjernFormatering
       
        Application.CutCopyMode = False
        Columns.AutoFit
    Next a
End Sub
Private Sub indsætOverskrifter()
Dim a As Integer, antalKolonner As Long, kol As String, adrVar As Variant, ræk As String
    Set arkHeader = ActiveWorkbook.Sheets(overskrifterArkNavn)
    arkHeader.Activate
    antalKolonner = ActiveCell.SpecialCells(xlLastCell).Column
    Cells(1, antalKolonner).Select
    adrVar = Split(Selection.Address, "$")
    kol = adrVar(1)
   
    For a = 0 To UBound(dArk)
        ræk = CStr(a + 1)
        arkHeader.Activate
        ActiveSheet.Range("A" & ræk & ":" & kol & ræk).Copy
       
        Set arkSamling = ActiveWorkbook.Sheets(dArk(a))
        arkSamling.Activate
        arkSamling.Range("A1").Select
     
        Selection.PasteSpecial Paste:=xlPasteAll
    Next
    Application.CutCopyMode = False
End Sub
Private Sub sletkolonner(sletkol)
Dim kolonne As String, k As Integer, omrSlet As Variant
    omrSlet = Split(sletkol, "-")
   
    For k = UBound(omrSlet) To 0 Step -1
        ActiveSheet.Columns(omrSlet(k)).Delete
    Next k
End Sub
Private Sub fjernFormatering()
    With ActiveSheet
        .Cells.Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
       
        With Selection.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
End Sub

Endnu engang tusinde tak for din hjælp Supertekst :-)

Selv tak..