Samenvattingen van diverse sheets

[royb73]

Beste,

Ik heb een code die aangepast moet worden, waar ik zelf niet uit kom.

De huidige code (zie hieronder) maakt een samenvatting van alle tabbladen (met 3 karakters) in 1 sheet ("samenvatting"). Tevens kunnen het automatisch aanmaken van de kopteksten eruit: "B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige. Ik heb een template gemaakt van de sheet Samenvatting -1, 00 etc.

Het is nu de bedoeling dat er per verdieping een samenvatting gemaakt wordt (zie voorbeeld bestand). Ik heb handmatig sheet "KSA" samengevat in sheets "Samenvatting -1, Samenvatting 00, Samenvatting 01, Samenvatting 02, Samenvatting 03".

De verdieping staat in de sheets (met de 3 karakters: KSA, KHL etc.) in cel F15 (-1), J15 (00), N15 (01), R15 (02), V15 (03). De samenvatting moet dan van verdieping -1 komen in sheet "Samenvatting -1".

Sub Summary_All_Worksheets_With_Formulas()
    Dim Sh As Worksheet
    Dim Newsh As Worksheet
    Dim myCell As Range
    Dim ColNum As Integer
    Dim RwNum As Long
    Dim Basebook As Workbook

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Delete the sheet "Summary-Sheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("Samenvatting").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Summary-Sheet"
    Set Basebook = ThisWorkbook
    Set Newsh = Basebook.Worksheets.Add
    Newsh.Name = "Samenvatting"

    'The links to the first sheet will start in row 2
    RwNum = 1

    For Each Sh In Basebook.Worksheets
        If Sh.Name <> Newsh.Name And Sh.Visible Then
            ColNum = 2
            RwNum = RwNum + 1
            'Copy the sheet name in the A column
            Newsh.Cells(RwNum, 1).Value = Sh.Name
            Newsh.Range("B1:G1").Value = Array("-1", "B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige")
            Newsh.Range("I1:N1").Value = Array("0", "B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige")
            Newsh.Range("P1:U1").Value = Array("1", "B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige")
            Newsh.Range("W1:AB1").Value = Array("2", "B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige")
            Newsh.Range("AD1:AI1").Value = Array("3", "B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige")
            Newsh.Range("AK1:AP1").Value = Array("4", "B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige")
            
            For Each myCell In Sh.Range("F23,F39,F49,F57,F65")  '<--Change the range
                ColNum = ColNum + 1
                Newsh.Cells(RwNum, ColNum).Formula = _
                "='" & Sh.Name & "'!" & myCell.Address(False, False)
            Next myCell

            ColNum = 9
            For Each myCell In Sh.Range("J23,J39,J49,J57,J65")  '<--Change the range
            ColNum = ColNum + 1
            Newsh.Cells(RwNum, ColNum).Formula = _
            "='" & Sh.Name & "'!" & myCell.Address(False, False)
            Next myCell
            
            ColNum = 16
            For Each myCell In Sh.Range("N23,N39,N49,N57,N65")  '<--Change the range
            ColNum = ColNum + 1
            Newsh.Cells(RwNum, ColNum).Formula = _
            "='" & Sh.Name & "'!" & myCell.Address(False, False)
            Next myCell
            
            ColNum = 23
            For Each myCell In Sh.Range("R23,R39,R49,R57,R65")  '<--Change the range
            ColNum = ColNum + 1
            Newsh.Cells(RwNum, ColNum).Formula = _
            "='" & Sh.Name & "'!" & myCell.Address(False, False)
            Next myCell
            
            ColNum = 30
            For Each myCell In Sh.Range("V23,V39,V49,V57,V65")  '<--Change the range
            ColNum = ColNum + 1
            Newsh.Cells(RwNum, ColNum).Formula = _
            "='" & Sh.Name & "'!" & myCell.Address(False, False)
            Next myCell
            
            ColNum = 37
            For Each myCell In Sh.Range("Z23,Z39,Z49,Z57,Z65")  '<--Change the range
            ColNum = ColNum + 1
            Newsh.Cells(RwNum, ColNum).Formula = _
            "='" & Sh.Name & "'!" & myCell.Address(False, False)
            Next myCell

        End If
    Next Sh
    
      Newsh.UsedRange.Columns.AutoFit

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Voorbeeld bestand is hier:

Bekijk bijlage test14092016.xlsm

Hopelijk is het duidelijk.

Alvast bedankt.

Groeten,

Roy.

 

[royb73]

Niemand??

 

[Leotaxi]

waar komt die Ja van, in tabblad samenvatting 01 ?


mvg
Leo

 

[royb73]

Leo, het gaat erom dat hij de waarde overneemt wat in de desbetreffende cel staat. Deze waarde moet dan gekopieerd worden in de sheet Samenvatting van de desbetreffende verdieping. Ja of Nee wordt handmatig ingevuld in de sheets met 3 karakters.

 

[Leotaxi]

daarom juist, ik vind die Ja niet terug in Tabblad KSA
dus over welke cell heb je het ?


mvg
Leo

 

[royb73]

Leo, je hebt gelijk. Er komt idd geen JA voor in KSA. Ik had dit even handmatig allemaal gedaan.

Hoop dat het duidelijk is wat ik bedoel.

Mvg

Roy

 

[Leotaxi]

Niet echt,

bv, in kolom opmerkingen, 7 rijen met data, welke neem je mee naar overzicht ?


mvg
Leo

 

[royb73]

Beste Leo,

De opmerkingen zou je voor nu weg kunnen laten.

Mvg

Roy