Opbouw samenvatting VBA

[royb73]

Beste mensen,

Ik heb een code die als eerst alle namen van de sheets in een nieuwe sheet ("Samenvatting") neerzet.
Vervolgens haalt hij de waarden van bepaalde cellen uit dat sheet en zet deze bij de desbetreffende onderdeel neer.

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

Echter wil ik opbouw anders hebben. Zie voorbeeld.xlsx sheet "Samenvatting2".


alvast bedankt.

Met vriendelijke groet,

RoyBekijk bijlage voorbeeld.xlsx

 

[snb]

Een voorbeeld van zo'n werkblad waaruit gegevens worden gehaald was ook niet verkeerd geweest.

De eerste 20 regels code kun je alvast vervangen door:

    If [not(isref(samenvatting!A1))] Then Worksheets.Add.Name = "samenvatting"

 

[royb73]

Excuses. Had verkeerde bijlage erin gezet. Juiste bijlage zit nu bij.

Mvg

roy

 

[gast0660]

@snb

Royvoorbeeld.xlsx

Wat is dat dan?

 

[snb]

Sub M_snb()
    If [not(isref(samenvatting!A1))] Then Sheets.Add.Name = "samenvatting"
    
    ReDim sn(6, 6)
    For j = 1 To 6
      sn(j, 0) = j - 2
    Next

    For Each sh In Sheets
        If Len(sh.Name) = 3 Then
            sp = sn
            sp(0, 0) = sh.Name
            For j = 1 To 30
              sp((j - 1) \ 5 + 1, (j - 1) Mod 5 + 2) = sh.[F23,J23,N23,R23,V23,Z23,F39,J39,N39,R39,V39,Z39,F49,J49,N49,R49,V49,Z49,F57,J57,N57,R57,V57,Z57,F65,J65,N65,R65,V65,Z65].Areas(j)
            Next
            
            Sheets("samenvatting").Cells(Rows.Count, 1).End(xlUp).Offset(2).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
        End If
    Next
End Sub

 

[royb73]

Beste SNB,

Code was bijna gelukt. .Alleen de volgorde was net iets anders aangezien de verdieping (-1,0,1 etc.) verticaal wordt gesorteerd.

Dit is de juiste volgorde nu,

Sh.[F23,F39,F49,F57,F65,J23,J39,J49,J57,J65,N23,N39,N49,N57,N65,R23,R39,R49,R57,R65,V23,V39,V49,V57,V65,Z23,Z39,Z49,Z57,Z65]

Wat ik nu nog mis, is als ik de code weer gebruik (m.b.v. een nog aan te maken knop), dan zou hij de aangemaakte sheet "Samenvatting" of moeten bijwerken of moeten verwijderen en opnieuw maken.

Tevens moet er nog kopteksten aangemaakt worden in Cel C2, D2, E2, F2, G2 etc:
"B-Bouwkunde", "W-Werktuigbouwkunde", "E-Elektrotechniek", "V-BHV / Beveiliging", "O-Overige"

Hoor het graag.

Met vriendelijke groet,

Roy