Code voor het middelen van waarden uit meerdere documenten

[dirk89]

Wij zijn een leveranciersbeoordeling aan het opzetten, die als input de waardering van verschillende medewerkers heeft. Hen wordt allen gevraagd een excel-document in te vullen waarin ze meerdere leveranciers, op verschillende criteria beoordelen met een cijfer van 1 t/m 10.

Al deze losse formulieren komen uiteindelijk samen in een hoofddocument, hierin staan de gemiddelde waardes van alle enquetes. Omdat het hier om verschrikkelijk veel data gaat willen we het graag automatiseren. Kan iemand ons op weg helpen met een voorbeeldcode? Liefst zouden we het dan ook nog zo hebben, dat lege cellen het gemiddelde niet omlaag trekken.

Ik heb een voorbeeldopzetje toegevoegd, van die enqueteformulieren komen er straks dus heel veel....

Bij voorbaat dank!
Bekijk bijlage Enquete002.xlsxBekijk bijlage Hoofddocument.xlsx

 

[Mark xl]

Beste Dirk 89,

Hier de code, hoef je gelijk niets meer aan te passen.

Er wordt vanuitgegaan dat de enquetes zijn geplaatst in de map "C:\enquete\"
dit kun je aanpassen door

 Private Const sEnquetemap As String = ""

aan te passen aan wat je wilt. zorg voor correct resultaat dat de "enquetemap" map enkel enquetebestanden bevat.

Maak van het resultaat een draaitabel (let op, elke kolom heeft een koptekst nodig om een draaitabel te kunnen maken),
- sleep leverancier naar rijlabels
- sleep de eigenschappen naar (som)Waarden , klik erop en kies voor "Waardevelden samenvatten op gemiddelde"

Er wordt nu alleen over het aantal beschikbare getallen het gemiddelde getoond, dus het gemiddelde wordt niet omlaag getrokken zoals je wenst.

Option Explicit
'de map met alle enquetes (let op de slash aan het einde)
Private Const sEnquetemap As String = "C:\enquete\"

Sub VulEnquete()
'vul het bestand met content van alle bestanden in de directory hierboven
Dim vfiles As Variant
Dim i As Long

    vfiles = GetExcelFiles(sEnquetemap)
    Application.ScreenUpdating = False
    
    For i = LBound(vfiles) To UBound(vfiles)
    
        CopyContent vfiles(i)
        Application.StatusBar = "Bezig met verwerken " & _
        vfiles(i) & "...   voortgang: " & _
        Int((100 / UBound(vfiles)) * i) & "%"

    Next

    Application.StatusBar = Empty
    Application.ScreenUpdating = True

End Sub

Private Sub CopyContent(ByVal vFile As Variant)
'Kopieer de content van een bestand naar de volgende cel
'   in kolom "A" van deze werkmap
Dim wb As Workbook

    Set wb = OpenExcelBook(vFile)
    
    If Not wb Is Nothing Then
        
        With wb.Sheets(1)
    
            .Range("A2", .Cells.SpecialCells(xlCellTypeLastCell)).Copy _
                Destination:=ThisWorkbook.Sheets(1).Range("A65535").End(xlUp).Offset(1)
    
        End With
        
        wb.Close , False
        Set wb = Nothing
    
    End If
    
End Sub

Private Function GetExcelFiles(ByVal sPath As String) As Variant
'Maak een array van alle Excel bestanden uit een werkmap
Dim oFile As Object
Dim sFound As String
Dim i As Long

    On Error GoTo Einde:
    
    With CreateObject("Scripting.filesystemobject").GetFolder(sPath)
        
        For Each oFile In .Files
        
            If IsExcelFile(CStr(oFile)) Then
            
                sFound = sFound & oFile & vbCr
            
            End If
        
        Next
    
    End With
    
Einde:

If sFound <> "" Then

    GetExcelFiles = Split(Mid(sFound, 1, Len(sFound) - 1), vbCr)
    
End If

End Function

Function IsExcelFile(ByVal sfile As String) As Boolean
'kijk na of het bestand een excel bestand is
Dim vExcelExt As Variant
Dim sFileExt As String
Dim i As Long
    
    vExcelExt = Array("xls", "xlsx", "xlsb", "xlsm")
    sFileExt = Mid(sfile, InStrRev(sfile, ".") + 1)
    
    For i = LBound(vExcelExt) To UBound(vExcelExt)
    
        If sFileExt = vExcelExt(i) Then
        
            IsExcelFile = True
            Exit For
    
        End If
    Next

End Function

Private Function OpenExcelBook(ByVal sfile As String) As Workbook
'open een werkmap als Workbook variabele
    On Error Resume Next
    Set OpenExcelBook = Workbooks.Open(sfile)

End Function

Succes,
Mark.