Thread: Code is copying data and formats to relevant worksheets, but not copying validation

I am SO hoping someone can help

I work for a NFP, and complete a very large quarterly report. I found this awesome code on contextures which does pretty much exactly what I need called AdvFilterCities, which runs a macro to send rows to individual sheets based on the value in column A.

There are a dozen or so managers all wanting input into the structure of this report, and the fields that are included/excluded are inevitably changed on an almost daily basis :@

My problem is, if on my master sheet (which I am using as the "template") I have all of my data validation set up, when I use the macro, the data validation doesn't get copied to the individual sheets.

Unfortunately the data validation is super important, because the people completing the report struggle with what accumulative totals are, and in one quarter may put a figure of 67, and in the next put 43.


So in total, I have a "Master Sheet" with 24 regions/offices, with their respective programs, of which there are 14 different programs across the regions (some programs are run from multiple offices, such as homelessness assistance). There are then 24 individual sheets - 1 for each regional office.

(I then just Paste, and Paste Special > Paste Link into another sheet from every ind. sheet so that I have a comprehensive report with all data across all sites, that's updated automatically)

If I can have this one master sheet update all the fields on the other sheets, including the data validation, I'd be a happy girl (and less likely to need copious bottles of wine!!)

This is the Code - with all credit to Contextures for their awesomeness!!!:

Option Explicit

Sub FilterCities()
  ' Developed by Contextures Inc.
  ' www.contextures.com
  'last edited March 18, 2004
  
  
    Dim myCell As Range
    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim TempWks As Worksheet
    Dim rsp As Integer
    Dim i As Long

    'include bottom most header row
    Const TopLeftCellOfDataBase As String = "A4"

    'what column has your key values
    Const KeyColumn As String = "A"

    'where's your data
    Set DataBaseWks = Worksheets("Template")
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
    
    Set TempWks = Worksheets.Add

    With DataBaseWks
        Set dummyRng = .UsedRange
        Set myDatabase = .Range(TopLeftCellOfDataBase, _
                            .Cells.SpecialCells(xlCellTypeLastCell))
    End With

    'rebuild the List
    With DataBaseWks
        Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=TempWks.Range("A1"), _
            Unique:=True

        'Add the heading to the criteria area
        TempWks.Range("D1").Value = _
            .Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
    End With

    With TempWks
        Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
    End With

    With ListRange
        .Sort Key1:=.Cells(1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom
    End With

    'check for individual worksheets
    For Each myCell In ListRange.Cells
        If WksExists(myCell.Value) = False Then
            Set wks = Sheets.Add
            On Error Resume Next
            wks.Name = myCell.Value
            If Err.Number <> 0 Then
                MsgBox "Please rename: " & wks.Name
                Err.Clear
            End If
            On Error GoTo 0
            wks.Move After:=Sheets(Sheets.Count)
        Else
            Set wks = Worksheets(myCell.Value)
            wks.Cells.Clear
        End If

        If rsp = 6 Then
          DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
        End If
        
        'change the criteria in the Criteria range
        TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)

        'transfer data to individual worksheets
        If rsp = 6 Then
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1").Offset(i, 0), _
              Unique:=False
        Else
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1"), _
              Unique:=False
        End If
    Next myCell

    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True

    MsgBox "CS Data Report Individual Sheets have been updated"

End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

If anyone can help, I swear I will be your biggest ever fan. This is doing my head in.

Try this adaption of the code. I change the Advanced Filter to filter in place and then copy.

Sub FilterCities()
' Developed by Contextures Inc.
' www.contextures.com
'last edited March 18, 2004


    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim TempWks As Worksheet
    Dim myCell As Range
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim rsp As Integer
    Dim i As Long

    'include bottom most header row
    Const TopLeftCellOfDataBase As String = "A4"

    'what column has your key values
    Const KeyColumn As String = "A"

    'where's your data
    Set DataBaseWks = Worksheets("Template")
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

    Set TempWks = Worksheets.Add

    With DataBaseWks
        Set dummyRng = .UsedRange
        Set myDatabase = .Range(TopLeftCellOfDataBase, _
                                .Cells.SpecialCells(xlCellTypeLastCell))
    End With

    'rebuild the List
    With DataBaseWks
        Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=TempWks.Range("A1"), _
                Unique:=True

        'Add the heading to the criteria area
        TempWks.Range("D1").Value = _
        .Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
    End With

    With TempWks
        Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
    End With

    With ListRange
        .Sort Key1:=.Cells(1), Order1:=xlAscending, _
              Header:=xlNo, OrderCustom:=1, _
              MatchCase:=False, Orientation:=xlTopToBottom
    End With

    'check for individual worksheets
    For Each myCell In ListRange.Cells
        If WksExists(myCell.Value) = False Then
            Set wks = Sheets.Add
            On Error Resume Next
            wks.Name = myCell.Value
            If Err.Number <> 0 Then
                MsgBox "Please rename: " & wks.Name
                Err.Clear
            End If
            On Error GoTo 0
            wks.Move After:=Sheets(Sheets.Count)
        Else
            Set wks = Worksheets(myCell.Value)
            wks.Cells.Clear
        End If

        If rsp = 6 Then
            DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
        End If

        'change the criteria in the Criteria range
        TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)

        'transfer data to individual worksheets
        If rsp = 6 Then
            myDatabase.AdvancedFilter _
                    Action:=xlFilterInPlace, _
                    CriteriaRange:=TempWks.Range("D1:D2")
            With wks
                myDatabase.SpecialCells(xlCellTypeVisible).Copy Destination:=.Range("A1").Offset(i, 0)
            End With
        Else
            myDatabase.AdvancedFilter _
                    Action:=xlFilterInPlace, _
                    CriteriaRange:=TempWks.Range("D1:D2")
            With wks
                myDatabase.SpecialCells(xlCellTypeVisible).Copy Destination:=.Range("A1")
            End With

        End If
    Next myCell

    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True

    MsgBox "CS Data Report Individual Sheets have been updated"

End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function