VBA code copies to relevant sheets - but doesn't copy the data validation?

L

Loz_Oz

New Member
Joined
Apr 30, 2007
Messages
15
I need help... before I either cry or drink myself into a stupor :-/

I found this awesome awesome code on contextures which does pretty much exactly what I need for a large data report for a NFP organisation that I work for, it's called AdvFilterCities.

It works for me because 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 :mad:

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 managers here apparently cannot grasp the concept of what accumulative totals are, are in one quarter may put a figure of 67, and in the next put 43.

Please please please can someone help?????
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
If you are using a PasteSpecial in your code, you can add:
Range.PasteSpecial paste:= xlPasteValidation
in sequence with whatever other paste types you are using.
 
Upvote 0
Hi Jo,

Wow thanks for the quick response!!

Unfortunately it's using copy ... no paste special :( that was the first thing I went looking for!!

How do I paste the code? Is there a special way to do this? It appears there used to be a HTML Maker thing that is no longer available :s
 
Upvote 0
Hmmm turns out my workbook is too large for excel jeanie...

If I'm not making any sense, I have a public drop box folder that I am happy to put a copy of this into, if that helps?


But I will do my best to explain ...

here is the code: (it's loooong)

Code: 
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


Now the actual sheets...

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 14 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)

The 12 managers with input tend to chop and change what data they want reported on for any given quarter. To be honest, I am getting sick of manually updating 24 different sheets, several times over, because one manager wants one demographic reported on, and another thinks it is inappropriate and has me remove it, but then adds a few other fields for reporting. It's doing my head in.

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!!)
 
Upvote 0
Hi,
Try this modified a bit code:
Rich (BB code): 

Sub FilterCities()
' Developed by Contextures Inc.
' www.contextures.com
' last edited March 18, 2004
' Link: http://www.contextures.com/AdvFilterCity.zip
'
' ZVI:2011-11-22 - modified for http://www.mrexcel.com/forum/showthread.php?t=593913


  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("Master Sheet")
  i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

  rsp = MsgBox("Include headings?", vbYesNo, "Headings")
  'rsp = vbYes  ' define it directly to vbYes/vbNo if required

  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 City 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 = vbYes 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 City worksheets
    '--> ZVI: modified
    myDatabase.AdvancedFilter _
        Action:=xlFilterInPlace, _
        CriteriaRange:=TempWks.Range("D1:D2"), _
        Unique:=False
    myDatabase.Copy wks.Range("A1").Offset(IIf(rsp = vbYes, i, 0))
    wks.UsedRange.Columns.AutoFit
    '<--

  Next

  DataBaseWks.ShowAllData   '<-- ZVI: added

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

  'MsgBox "Data has been sent"

End Sub

Function WksExists(wksName As String) As Boolean
  On Error Resume Next
  WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
 
Last edited:
Upvote 0
ZVI said:
Hi,
Try this modified a bit code:
Rich (BB code): 

Sub FilterCities()
' Developed by Contextures Inc.
' www.contextures.com
' last edited March 18, 2004
' Link: http://www.contextures.com/AdvFilterCity.zip
'
' ZVI:2011-11-22 - modified for http://www.mrexcel.com/forum/showthread.php?t=593913


  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("Master Sheet")
  i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

  rsp = MsgBox("Include headings?", vbYesNo, "Headings")
  'rsp = vbYes  ' define it directly to vbYes/vbNo if required

  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 City 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 = vbYes 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 City worksheets
    '--> ZVI: modified
    myDatabase.AdvancedFilter _
        Action:=xlFilterInPlace, _
        CriteriaRange:=TempWks.Range("D1:D2"), _
        Unique:=False
    myDatabase.Copy wks.Range("A1").Offset(IIf(rsp = vbYes, i, 0))
    wks.UsedRange.Columns.AutoFit
    '<--

  Next

  DataBaseWks.ShowAllData   '<-- ZVI: added

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

  'MsgBox "Data has been sent"

End Sub

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

ZVI thank you thank you thank you!!! I am eternally grateful!!! I may actually get some sleep tonight instead of sulking all night that I am, as yet, too stupid to really get it with VBA.

Sincerely, thank you!!
 
Upvote 0
Hi ZVI .. thanks again ... yep I had some sleep for a change!!

One more question though if I may be so bold? How do I get this to copy over the column/row widths/heights? Is this even possible?

:D
 
Upvote 0
Loz_Oz said:
How do I get this to copy over the column/row widths/heights? Is this even possible?
Click to expand...
Like this?
Rich (BB code): 

Sub FilterCities()
' Developed by Contextures Inc.
' www.contextures.com
' last edited March 18, 2004
' Link: http://www.contextures.com/AdvFilterCity.zip
'
' ZVI:2011-11-22 - modified for http://www.mrexcel.com/forum/showthread.php?t=593913

  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("Master Sheet")
  i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

  rsp = MsgBox("Include headings?", vbYesNoCancel, "Headings")
  'rsp = vbYes  ' define it directly to vbYes/vbNo if required
  
  '--> ZVI: added
  If rsp = vbCancel Then Exit Sub
  Application.ScreenUpdating = False
  '<--

  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 City 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 = vbYes 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 City worksheets
    '--> ZVI: modified
    myDatabase.AdvancedFilter _
        Action:=xlFilterInPlace, _
        CriteriaRange:=TempWks.Range("D1:D2"), _
        Unique:=False
    myDatabase.Copy
    With wks.Range("A1").Offset(IIf(rsp = vbYes, i, 0))
      .PasteSpecial xlPasteColumnWidths
      .PasteSpecial xlPasteAll
    End With
    wks.Activate
    wks.Cells(1).Select
    Application.CutCopyMode = False
    '<--

  Next

  Application.DisplayAlerts = False
  TempWks.Delete
  Application.DisplayAlerts = True
  
  '--> ZVI: added
  DataBaseWks.Activate
  DataBaseWks.ShowAllData
  Application.ScreenUpdating = True
  '<--

  'MsgBox "Data has been sent"

End Sub

Function WksExists(wksName As String) As Boolean
  On Error Resume Next
  WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question
Help with VB Code to copy workbook
Replies
0
Views
200
kizzie37
K
P
  • Solved
VBA Match data, find mismatch data and copy data to validation sheet. Not working correctly.
2
Replies
16
Views
794
pawcoyote
P
V
  • Question
Restrict Cut-Copy-Paste in the specific range of cells having data validation in a particular Sheet of a workbook
Replies
0
Views
572
Vishal Gupta
V
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
389
Agnarr
Agnarr
V
  • Question
Unprotect doesn't work with VBA code
Replies
2
Views
463
VIorica000
V

Forum statistics

Threads
1,215,580
Messages
6,125,653
Members
449,245
Latest member
PatrickL

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top