Macro aanpassen aan tabbladen + formule

Status
Niet open voor verdere reacties.
T

Tweety1

Gebruiker
Lid geworden
6 mrt 2013
Berichten
637
Ik heb volgende macro van de site van Ron de Bruin gebruikt alleen zou ik graag 3 aanpassingen willen doen alleen ik kom er niet uit

De aanpassingen die ik graag erin wil verwerken zijn

1. Alleen de sheet 2 tot de 1 laatste sheet.
2. De volgende formule =AANTAL.ALS(XXXX!A:A;"*")-1 (Zowel in een engelse en Nederlandse versie van excel
3. Eind totaal van de som (Kolom A de tekst Totaal en kolom B de som


Code: 
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 "Totaal" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("Totaal").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Totaal"
    Set Basebook = ThisWorkbook
    Set Newsh = Basebook.Worksheets.Add
    Newsh.Name = "Totaal"
    '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 = 1
            RwNum = RwNum + 1
            'Copy the sheet name in the A column
            Newsh.Cells(RwNum, 1).Value = Sh.Name

            For Each myCell In Sh.Range("A11")  '<--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
 
Plaats voor deze vraag maar eens een voorbeeldbestand met enkele werkbladen met gegevens en 1 werkblad met wat het eindresultaat moet zijn.
 
Code: 
Sub Overzicht()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Totaal").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    For i = 2 To Sheets.Count - 1
        If Not dic.exists(Sheets(i).Name) Then
            dic.Add Sheets(i).Name, WorksheetFunction.CountA(Sheets(i).Columns(1)) - 1
        End If
    Next
    With Sheets.Add
        .Name = "Totaal"
        .Range("A1").Resize(, 2) = Array("Sheet", Date)
        .Range("A2").Resize(dic.Count).Value = Application.Transpose(dic.keys)
        .Range("B2").Resize(dic.Count).Value = Application.Transpose(dic.items)
    End With
    Application.ScreenUpdating = True
End Sub
 
Ik heb de macro verder uitgebouwd. allen lukt het me niet om in de cel naast "Aantal minder..." de formule "=SOM(C??-B??)" te plaatsen.


Code: 
Sub Overzicht()
    Dim dic As Object
    Dim Bereik As Range
    Dim waarde As Double
    Set dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Totaal").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    For i = 2 To Sheets.Count - 1
        If Not dic.exists(Sheets(i).Name) Then
            dic.Add Sheets(i).Name, WorksheetFunction.CountA(Sheets(i).Columns(1)) - 1
        End If
    Next
    With Sheets.Add
        .Name = "Totaal"
        .Range("A1").Resize(, 2) = Array("Sheet", Date)
        .Range("A2").Resize(dic.Count).Value = Application.Transpose(dic.keys)
        .Range("B2").Resize(dic.Count).Value = Application.Transpose(dic.items)
    End With
    
    Range("A1").Select
    Cells(1, Selection.Column).End(xlDown).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "Totaal"
    With ActiveCell.Borders(xlEdgeTop)
        .LineStyle = xlNone
        .Weight = xlMedium
    End With
    Range("B1").Select
    Cells(1, Selection.Column).End(xlDown).Offset(1, 0).Select
    With ActiveCell.Borders(xlEdgeTop)
        .LineStyle = xlNone
        .Weight = xlMedium
    End With
    
    Set Bereik = Range(Range("B2"), Range("B65536").End(xlUp))
        waarde = WorksheetFunction.Sum(Bereik)
    Range("B65536").End(xlUp).Offset(1, 0).Value = IIf(waarde = 0, "", waarde)

    Columns("A:A").EntireColumn.ColumnWidth = 14.29
    Columns("B:Z").EntireColumn.ColumnWidth = 10.71
    Columns("B:Z").HorizontalAlignment = xlCenter
    
    Range("A1").Select
    Cells(1, Selection.Column).End(xlDown).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = " "
    Cells(1, Selection.Column).End(xlDown).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "Aantal minder ten opzichte van vorige week"
    ActiveCell.WrapText = True
    
    Range("B1").Select
    Cells(1, Selection.Column).End(xlDown).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = " "
    Cells(1, Selection.Column).End(xlDown).Offset(1, 0).Select
    ActiveCell.VerticalAlignment = xlCenter

    Range("A1").Select
    
    Application.ScreenUpdating = True
End Sub
 
Begin eerst eens iedere 'Select' en 'Activate' te verwijderen uit de code.
 
Code: 
Sub Overzicht()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Totaal").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    For i = 2 To Sheets.Count - 1
        If Not dic.exists(Sheets(i).Name) Then
            dic.Add Sheets(i).Name, WorksheetFunction.CountA(Sheets(i).Columns(1)) - 1
        End If
    Next
    With Sheets.Add
        .Columns(1).ColumnWidth = 14.29
        .Name = "Totaal"
        .Range("A1").Resize(, 2) = Array("Sheet", Date)
        .Range("A2").Resize(dic.Count).Value = Application.Transpose(dic.keys)
        .Range("B2").Resize(dic.Count).Value = Application.Transpose(dic.items)
        With .Cells(dic.Count + 2, 1)
            .Value = "Totaal"
            With .Resize(, 2).Borders(xlEdgeTop)
                    .LineStyle = xlNone
                    .Weight = xlMedium
            End With
            With .Offset(2)
                .Value = "Aantal minder ten opzichte van vorige week"
                .WrapText = True
            End With
            .Offset(2, 1).FormulaR1C1 = "=R[-2]C[1]-R[-2]C"
        End With
        .Cells(dic.Count + 2, 2) = WorksheetFunction.Sum(.Cells(2, 2).Resize(dic.Count))
        With .Columns(2).Resize(, 27)
            .ColumnWidth = 10.71
            .HorizontalAlignment = xlCenter
        End With
    End With
    Application.ScreenUpdating = True
End Sub
 
Heel erg bedankt. Ik was zelf ook nog bezig geweest met de 1e macro. Nou zou ik graag het laatste stukje van de macro van (Warme bakkertje) willen toevoegen


Code: 
Sub Summary_All_Worksheets_With_Formulas()
    Dim Sh As Worksheet
    Dim Newsh As Worksheet
    Dim myCell As Variant
    Dim ColNum As Integer
    Dim RwNum As Long
    Dim Basebook As Worksheet
    Dim LastRow As Long
    
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Delete the sheet "Totaal" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    Worksheets("Totaal").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Totaal"
    'Set Basebook = ThisWorkbook
    Set Newsh = Worksheets.Add
    Newsh.Name = "Totaal"
    
    Newsh.Range("A1").Resize(, 2) = Array("Opleiding", Date)
    Newsh.Columns(1).ColumnWidth = 14.29
    'The links to the first sheet will start in row 2
    RwNum = 1

    For Each Sh In Worksheets
        If Sh.Name <> Newsh.Name And Sh.Visible And Not Sh.Name = "sheet1" Then
            ColNum = 1
            RwNum = RwNum + 1
            'Copy the sheet name in the A column
            Newsh.Cells(RwNum, 1).Value = Sh.Name

[COLOR="#FF0000"]            For Each myCell In Sh.Range("A2")  '<--Change the range
            LastRow = Sh.Range("A65000").End(xlUp).Row
                ColNum = ColNum + 1
                Newsh.Cells(RwNum, ColNum).Formula = _
                "=COUNTIF('" & Sh.Name & "'!" & myCell.Address(False, False) & ":A" & LastRow & ",""*"")"[/COLOR]
                
            Next myCell
            
        End If
    Next Sh

    Newsh.UsedRange.Columns.AutoFit

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

Toevoegen
Code: 
       With .Cells(dic.Count + 2, 1)
            .Value = "Totaal"
            With .Resize(, 2).Borders(xlEdgeTop)
                    .LineStyle = xlNone
                    .Weight = xlMedium
            End With
            With .Offset(2)
                .Value = "Aantal minder ten opzichte van vorige week"
                .WrapText = True
            End With
            .Offset(2, 1).FormulaR1C1 = "=R[-2]C[1]-R[-2]C"
        End With
        .Cells(dic.Count + 2, 2) = WorksheetFunction.Sum(.Cells(2, 2).Resize(dic.Count))
        With .Columns(2).Resize(, 27)
            .ColumnWidth = 10.71
            .HorizontalAlignment = xlCenter
        End With
    End With
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan