Cellen uit meerdere excel bestanden in nieuw excel bestand

[knaap37]

Hallo,

Ik heb tientallen excel bestanden in één map met allemaal dezelfde opbouw van worksheetnamen en in de worksheets ook dezelfde opbouw van cellen.

Nu wil ik één overzicht excel bestand maken en van de tientallen excel bestanden vanuit de worksheet met de naam 'calc' hetzelfde aantal cellen (A123:AZ127) onder elkaar in het overzichtsbestand zetten.

Dit wil ik met een knop kunnen updaten, zodat het overzichtsbestand zoekt naar eventuele nieuwe excel bestanden in de map en alle waarden in de cellen updatet.

Ik heb het een en ander met VBA geprobeerd maar ik kom er niet uit, ook op google kan ik niet precies vinden wat ik zoek.

Alvast bedankt voor jullie reacties.

[MAX3400]

Create an external reference (link) to a cell range in another workbook ?

[ Voor 22% gewijzigd door MAX3400 op 14-07-2017 09:48 ]

[knaap37]

Dit had ik inderdaad ook al geprobeerd, maar dat houdt in dat ik elke keer als er een nieuw excel bestand in de map bijkomt, ik dit handmatig in het overzichtsbestand moet toevoegen en de naam van het excel bestand moet intypen.
Dit wil ik graag automatiseren door middel van een knop in het overzichtsbestand, waardoor het hele overzichtsbestand geüpdate wordt en de genoemde cellen van eventuele nieuwe bestanden toegevoegd worden aan het overzicht.

[MAX3400]

Dat kan ook inderdaad; het makkelijkst is VBA. Hier een random snippet om automatisch hyperlinks in Excel te genereren op basis van MP3-files in een directory.

Met enige inzet, kan dit vast worden omgebouwd van MP3 naar XLS en van hyperlink naar cell-reference

code:

Sub MakeHyperlinks()
    Dim sPath As String
    Dim sFile As String
    Dim iRow As Integer

    'specify directory to use - must end in "\"
    sPath = "C:\Documents\Birdsongs\"

    iRow = 0
    sFile = Dir(sPath)
    While sFile <> ""
        iRow = iRow + 1
        Sheet1.Cells(iRow,1) = sFile
        sBird = Left(sFile, Len(sFile)-4)
        ActiveSheet.Hyperlinks.Add Anchor:=Sheet1.Cells(iRow,1), _
          Address:=sPath & sFile, TextToDisplay:=sBird
        sFile = Dir     ' Get next filename
    Wend
End Sub

[Lustucru]

knaap37 schreef op vrijdag 14 juli 2017 @ 09:44:

Ik heb het een en ander met VBA geprobeerd maar ik kom er niet uit, ook op google kan ik niet precies vinden wat ik zoek.

Post dan ook even wat je wél hebt (vergeet de code-tags niet) en waar je niet uitkomt. Desnoods geef je ook aan wat je op google hebt gevonden en waarom dat niet voldoet.

[knaap37]

Hieronder zie je een voorbeeld van een bestand, deze gegevens wil ik weergeven in het overzicht. De bestanden hebben altijd dezelfde opbouw (hetzelfde aantal cellen gevuld en op dezelfde plek):



De lijst met namen van alle bestanden uit de map haal ik binnen met de vba code onderaan dit bericht. Vervolgens heb ik de namen van de bestanden die ik binnen wil halen, met de hand in de formule ingetypt zoals op de afbeelding hieronder te zien is. Ik wil dit automatiseren d.m.v. de naam die ik heb binnengehaald in de cel links in het gedeelte in de formule te plaatsen.



Hierbij de code die ik gebruik om alle namen van de excel bestanden uit de betreffende map binnen te halen in de excel sheet.

code:

Sub GetFiles()
    Dim fileList() As String
    Dim fName As String
    Dim i As Integer, X As Integer
    fPath = "C:\Users\Rimato\Downloads\Test\Bestanden\"
    fName = Dir(fPath & "*.xls*")
    While fName <> ""
        i = i + 6
        ReDim Preserve fileList(1 To i)
        fileList(i) = fName
         fName = Dir()
    Wend
    If i = 0 Then
        MsgBox "Geen bestanden gevonden"
        Exit Sub
    Else
        Columns(1).ClearContents
        For X = 1 To i
            Cells(X, 1) = fileList(X)
        Next
    End If
    Application.CalculateFull
End Sub

[Lustucru]

Het lijkt me handiger om het bestand te openen en de waarden even te kopieren naar je nieuwe bestand.
In de basis is het dan niet meer dan dit:

Visual Basic:

Sub Getfiles()

    Dim fpath As String, fname As String, curRow As Long, ws As Worksheet, wb As Workbook

    fpath = "C:\temp\"
    currow = 1
    
    Set ws = ActiveSheet
    ws.Cells.ClearContents
    
    fname = Dir(fpath & "*.xlsx")
    While fname <> ""
        Set wb = Workbooks.Open(fpath & fname)
        ws.Cells(currow, 1) = fname
        wb.Sheets(1).Range("a1:C6").Copy ws.Cells(currow, 2)
    
        currow = currow + 7
        wb.Close
        fname = Dir
    Wend

End Sub

Moet wel afgewerkt worden met foutafhandeling, screenupdating om geflikker te voorkomen en eventueel berichten aan het einde.

[ Voor 4% gewijzigd door Lustucru op 15-07-2017 16:22 ]

[knaap37]

Het is gelukt, bedankt voor de tips!

Met dit stukje code uit de gehele code pak ik de tekst uit de cel en gebruik ik die in de formule:

code:

            Cells(13 + (X - 1) * 6, 2).Value = "='" & fPath & "[" & fileList(X) & "]" & fSheet & "'!" & fCell

fPath is een variabele waarin de bestandsmap staat
fileList (X) is de naam van het bestand
fSheet is de naam van de worksheet uit het bestand waaruit die de cellen pakt
fCell is de cel

Nadat de formule in de eerste cel staat kopieer ik dit door naar de rest van de cellen m.b.v. de codes die erop volgen

Hier is de hele code die ik heb gebruikt:

code:

Sub VerzamelOffertes()
    Dim fileList() As String
    Dim fName As String
    Dim fPath As String
    Dim fSheet As String
    Dim i As Integer, X As Integer
    fPath = Range("B1").Value
    fName = Dir(fPath & "*.xls*")
    fSheet = Range("M1").Value
    fCell = Range("R1").Value
    
    Application.ScreenUpdating = False
    
    Rows("12:9999").Delete Shift:=xlUp

    While fName <> ""
        i = i + 1
        ReDim Preserve fileList(1 To i)
        fileList(i) = fName
         fName = Dir()
 
    Wend
    If i = 0 Then
        MsgBox "Geen bestanden gevonden"
        Exit Sub
    Else
        For X = 1 To i
        'maak lijst van offertenamen
            Cells(13 + (X - 1) * 6, 1) = fileList(X)
            
        'zet formule in de cel rechts naast de offertenaam
            Cells(13 + (X - 1) * 6, 2).Value = "='" & fPath & "[" & fileList(X) & "]" & fSheet & "'!" & fCell
         
        'kopieer cel naar rechts
            Cells(13 + (X - 1) * 6, 2).AutoFill Destination:=Range(Cells(13 + (X - 1) * 6, 2), Cells(13 + (X - 1) * 6, 53)), Type:=xlFillDefault
        
        'kopieer hele rij naar onder
            Range(Cells(13 + (X - 1) * 6, 2), Cells(13 + (X - 1) * 6, 53)).AutoFill Destination:=Range(Cells(13 + (X - 1) * 6, 2), Cells(17 + (X - 1) * 6, 53)), Type:=xlFillDefault
            
        'kopieer opmaak van samenvattende tabel
            Range("B6:BA10").Copy
            Cells(13 + (X - 1) * 6, 2).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
            
        'maak blok van titel
            Range(Cells(13 + (X - 1) * 6, 1), Cells(17 + (X - 1) * 6, 1)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
            
            Range("A1").Select
            
        Next
    End If
    Application.CalculateFull
            Range("A13").Select
            
    Application.ScreenUpdating = True
End Sub