Help with VBA Coding needed

zookeeperbobbie

Board Regular
Joined
Feb 9, 2005
Messages
117
Hello- I have a spreadsheet that I found somewhere that I need modified.

Currently there is a filter that will put data from a main sheet into a sheet based on certin criteria. The only problem is that its replacing The top few rows which I need to remain the same and not be copied over because I have formulas in the top headers.
Thanks for your help in advance.

Here is the code-

Code:
Option Explicit

Sub FilterCities()
    '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("Main")
        i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
        
        rsp = MsgBox("Include headings?", vbYesNo, "Headings")
        
        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 = 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 City 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 "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

EDIT: Added Code tags - Smitty
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

Joe Was

MrExcel MVP
Joined
Feb 19, 2002
Messages
7,539
Just change the starting address in the "CopyTo" statements!
 

zookeeperbobbie

Board Regular
Joined
Feb 9, 2005
Messages
117
Hi, Thanks for your help. That worked perfect.
Now I didnt think this was going to happen, but when ever i type information above where the new data was pasted. Lets say its now being pasted in A10. I enter information is A6-8 AND D6-8.
When I enter new information in the main sheet and hit send data, The information i typed in A6-6AND D6-8 is earased. Any ideas?
Thanks
Bobbi Anne
 

Joe Was

MrExcel MVP
Joined
Feb 19, 2002
Messages
7,539
This is the code that is doing the erase:

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


You need to add a test in this code to exclude the erase under some condition, what that is I do not know. It could be as simple as:

If ISNUMBER(myCell.Value) = True

Or something.
 

zookeeperbobbie

Board Regular
Joined
Feb 9, 2005
Messages
117
Hi- I tried playing around with this and All i got was error messages...

Pretty much the only thing that I really need is a space where i can add additional text without it being erased when i refresh the information.
Even if i can modify the main sheet that will be fine too. That was it would post along with the other information. I just have no idea how to do this.
If it would help I could post a link where the spreadsheet could be downloaded...

Thanks
 

Forum statistics

Threads
1,141,060
Messages
5,704,037
Members
421,323
Latest member
Exidous

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
Top