Excel 2010 VBA - Rows not appending

I am creating a Macro with VBA in Excel 2010 to move rows fro开发者_开发问答m one sheet to another based on the DOB and State cell (all the in same workbook).

The macro checks the DOB against a "cut-off" date and if the row passes, the row should be appended to the TSP sheet and deleted from Sheet1.

If it didn't pass, then it checks to see if a state sheet exists for the row's "State" cell. If it does, then the row should be appended to the end of that sheet and is deleted from Sheet1.

If the row doesn't meet any of the two it is simply left to be manually checked as it either missing data or the data was entered incorrectly.

All is working correctly except for the appending of the row to the sheet. It is simply replacing the last row of the sheet except for the OH sheet, which is working for whatever reason.

My Macro:

Sub Move()
'
' Move Macro
'
' Keyboard Shortcut: Ctrl+Shift+M
' Declare and set variables
Dim CBL_DATE
Dim totalrows, c
Set tsp_sheet = Sheets("TSP")
Set people = Sheets("Sheet1")
CBL_DATE = DateAdd("yyyy", -59.5, Date)
' Find total number of people to move
totalrows = people.UsedRange.Rows.Count
' Step through each row
For Row = totalrows To 2 Step -1
    ' Do not do anything if row is 1
    If Row >= 2 Then
        ' Check for CBL cut off date and move to TSP sheet
        If Cells(Row, 3).Value < CBL_DATE Then
            tsp_sheet.Rows(tsp_sheet.UsedRange.Rows.Count + 1).Value = people.Rows(Row).Value
            people.Rows(Row).Delete
        Else
                ' Now we check for the state and if that worksheet exists, we copy to it and delete original
            If SheetExists(Cells(Row, 2).Value) Then
                Set st_sheet = Sheets(Cells(Row, 2).Value)
                c = st_sheet.UsedRange.Rows.Count + 1
                MsgBox Cells(Row, 2).Value & " " & c
                st_sheet.Rows(c).Value = people.Rows(Row).Value
                people.Rows(Row).Delete
            End If
        End If
    End If
Next Row
End Sub
' End Sub Move()

My Table for Sheet1

Sheet 1
Name    |State  |DOB
--------------------------                              Tim |MI |10/2/1978
Bob |MI |10/5/1949
Suesan  |TN |10/8/1978      
Debra   |OH |10/8/1975

All the other sheets are blank although I would love to start inserting at the second row (or count+1).

EDIT: My SheetExists() function

' Public Function SheetExists
Public Function SheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
SheetExists = False
For Each ws In ThisWorkbook.Worksheets
    If ws.Name = SheetName Then
        SheetExists = True
        Exit For
    End If
Next ws
End Function

In absence of the code for function SheetExists() I tested your code replacing

If SheetExists(Cells(Row, 2).Value) Then
    Set st_sheet = Sheets(Cells(Row, 2).Value)

by

If Cells(Row, 2).Value = "OH" Then
    Set st_sheet = Sheets("Sheet2")

The list is worked from bottom to top which is good as you delete (but not the only possible way). The first row matching the conditions is row #4 which is placed in row 2 of Sheet2, leaving 1 line blank (because of +1). This empty line #1 makes a bit of confusion for subsequent calls to UsedRange and the subsequent hit in row #2 (date condition) overwrites the first find.

BTW the 1st If Row >= 2 Then is superfluous because the sourrounding For sets the borders anyhow.

I would recommend to recode the whole Sub a bit ....

Sub Move1()
Dim SrcRng As Range, SrcIdx As Long
Dim TSPRng As Range, CtyRng As Range, TrgIdx As Long
Dim CblDate As Date

    Set SrcRng = Sheets("Sheet1").[A1] ' source sheet
    Set TSPRng = Sheets("Sheet2").[A1] ' target for date condition
    Set CtyRng = Sheets("Sheet2").[A1] ' target for country condition, preliminary set equal to TSP
    CblDate = DateAdd("yyyy", -59.5, Date)
    SrcIdx = 2                         ' 1st row is header row

    ' we stop on 1st blank in 1st column of SrcRng
    Do While SrcRng(SrcIdx, 1) <> ""
        If SrcRng(SrcIdx, 3) < CblDate Then
            ' copy to TSP sheet
            TrgIdx = GetIdx(TSPRng)
            SrcRng(SrcIdx, 1).EntireRow.Copy TSPRng(TrgIdx, 1)

            ' delete from source
            SrcRng(SrcIdx, 1).EntireRow.Delete xlShiftUp

        ElseIf SrcRng(SrcIdx, 2) = "OH" Then    ' replace by your on condition re country
            ' here you would set CtyRng acc. to some algorithm

            ' copy to Country sheet
            TrgIdx = GetIdx(CtyRng)
            SrcRng(SrcIdx, 1).EntireRow.Copy CtyRng(TrgIdx, 1)

            ' delete from source
            SrcRng(SrcIdx, 1).EntireRow.Delete xlShiftUp

        Else
            ' we don't increment after deletions, because all records move up anyhow
            SrcIdx = SrcIdx + 1

        End If

    Loop

End Sub

Function GetIdx(InRng As Range) As Long
' find row number of 1st empty row in 1st column of range InRng

    GetIdx = 1
    Do While InRng(GetIdx, 1) <> ""
        GetIdx = GetIdx + 1
    Loop

End Function

Of course, if you set your target sheets to [A2] instead of A1 you're starting to insert in the 2nd line ....

Hope that helps

Good luck MikeD

post acceptance edit

What was wrong:

The root cause clearly is that UsedRange.Rows.Count returns 1 for an empty sheet (at least in Excel 2003) which may come unexpected. This means that by writing into ...UsedRange.Rows.Count + 1 your first record is inserted into row #2 of an empty sheet. Unfortunately, with a single row in the sheet (in row #2 or elsewhere) you get the same result which makes the 2nd data record overwrite the first, and so forth because the row count never increases.

I tested this with debug-walking through this small

Sub test()
    Debug.Print ActiveSheet.UsedRange.Rows.Count
End Sub