Macro voor nieuwe sheet, maar dan gelijk verbergen

[Muiter]

Ik maak met veel plezier gebruik ban een macro die ik heb gevonden op de site van Ron de Bruin, de macro heet: Create a new sheet for all Unique values or paste it below the
existing data if the sheet exists

Wat moet ik in deze macro aanpassen zodat de sheets die worden aangemaakt gelijk zijn verborgen?

 

[Cobbe]

Sheets(1).Visible = xlSheetVeryHidden

Waarin (1) dient vervangen te worden door de naam van het nieuwe blad.

Cobbe

 

[Muiter]

Sheets(1).Visible = xlSheetVeryHidden

Waarin (1) dient vervangen te worden door de naam van het nieuwe blad.

Cobbe

Dat is niet helemaal wat ik bedoel, dan moet ik een nieuwe macro maken. De bladen zijn per document verschillend benoemd. Dus ik wil in de bestaande macro een code plaatsen zodat zonder tussenkomst van een andere macro of stap voor de gebruiker de bladen zijn verborgen.

 

[Wigi]

Dat is niet helemaal wat ik bedoel, dan moet ik een nieuwe macro maken. De bladen zijn per document verschillend benoemd. Dus ik wil in de bestaande macro een code plaatsen zodat zonder tussenkomst van een andere macro of stap voor de gebruiker de bladen zijn verborgen.

Daar moet geen nieuwe macro voor gemaakt worden.

Jij moet 1 regel code tussenvoegen, uiteraard nadat een blad al gemaakt is.

 

[Muiter]

Daar moet geen nieuwe macro voor gemaakt worden.

Jij moet 1 regel code tussenvoegen, uiteraard nadat een blad al gemaakt is.

Dat begrijp ik, de code kan ik niet genoeg ontcijferen om te weten waar ik die code op welke manier moet invullen.

Sub Copy_To_Worksheets_2()
' This sub uses the functions LastRow and SheetExists
    Dim CalcMode As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim WSNew As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim Lrow As Long
    Dim DestRange As Range
    Dim FieldNum As Integer
    Dim Lr As Long

    'Name of the sheet with your data
    Set ws1 = Sheets("Sheet1")  '<<< Change

    'Set filter range : A1 is the top left cell of your filter range and
    'the header of the first column, D is the last column in the filter range
    Set rng = ws1.Range("A1:D" & Rows.Count)

    'Set Field number of the filter column
    'This example filters on the first field in the range(change the field if needed)
    'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 1

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

    ' Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        rng.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a worksheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            If SheetExists(cell.Value) = False Then
                Set WSNew = Sheets.Add
                On Error Resume Next
                WSNew.Name = cell.Value
                If Err.Number > 0 Then
                    MsgBox "Change the name of : " & WSNew.Name & " manually"
                    Err.Clear
                End If
                On Error GoTo 0
                Set DestRange = WSNew.Range("A1")
            Else
                Set WSNew = Sheets(cell.Text)
                Lr = LastRow(WSNew)
                Set DestRange = WSNew.Range("A" & Lr + 1)
            End If

            'Firstly, remove the AutoFilter
            ws1.AutoFilterMode = False

            'Filter the range
            rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

            'Copy the visible data and use PasteSpecial to paste to the worksheet
            ws1.AutoFilter.Range.Copy
            With DestRange
                .Parent.Select
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
            ' Delete the header row if you copy to a existing worksheet
            If Lr > 0 Then WSNew.Range("A" & Lr + 1).EntireRow.Delete

            'Close AutoFilter
            ws1.AutoFilterMode = False

            Lr = 0
        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

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



Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function SheetExists(SName As String, _
                     Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
    On Error Resume Next
    If WB Is Nothing Then Set WB = ThisWorkbook
    SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

 

[WimenBeer]

Daar moet geen nieuwe macro voor gemaakt worden.

Jij moet 1 regel code tussenvoegen, uiteraard nadat een blad al gemaakt is.

Muiter,

In de code wordt gebruik gemaalkt van ws1 en ws2.
ws2 is het nieuw aangemaakte worksheet.
Dus na het einde van de 'With' kan je deze code toevoegen.

En dat is nou echt programmeren en niet proberen.

Wim

 

[Wigi]

In de code wordt gebruik gemaalkt van ws1 en ws2.
ws2 is het nieuw aangemaakte worksheet.

Neen, dat is fout.

WSNew is de variabele die Ron gebruikt voor nieuwe sheets.

Wigi