Excel 2010 VBA - строки не добавляются

Question

Я создаю макрос с VBA в Excel 2010 для перемещения строк с одного листа на другой на основе ячейки DOB и State (все в одной книге).

Макрос проверяет DOB по дате «отсечения», и если строка проходит, строка должна быть добавлена ​​к листу TSP и удалена из Sheet1.

Если он не прошел, то он проверяет, существует ли лист состояния для ячейки «Состояние» строки. Если это так, то строка должна быть добавлена ​​в конец этого листа и удалена из листа 1.

Если строка не соответствует ни одной из двух, ее просто оставляют для проверки вручную, поскольку в ней либо отсутствуют данные, либо данные были введены неправильно.

Все работает правильно, за исключением добавления строки к листу. Он просто заменяет последний ряд листа, за исключением листа OH, который работает по любой причине.

Мой макрос:

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

Мой стол для листа1

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

Все остальные листы не заполнены, хотя я хотел бы начать вставлять во второй ряд (или считать + 1).

РЕДАКТИРОВАТЬ: моя функция SheetExists ()

' 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

Answer 1

В отсутствие кода для функции SheetExists () я протестировал ваш код, заменив

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

от

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

Список работает снизу вверх, что хорошо при удалении (но не единственный возможный способ). Первая строка, соответствующая условиям, - это строка № 4, которая помещается в строку 2 Листа 2, оставляя 1 строку пустой (из-за +1). Эта пустая строка # 1 создает некоторую путаницу для последующих вызовов к UsedRange, и последующее попадание в строку # 2 (условие даты) перезаписывает первую находку.

Кстати, 1-й If Row >= 2 Then излишен, потому что окружение For так или иначе устанавливает границы.

Я бы порекомендовал немного перекодировать весь саб ....

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

Конечно, если вы установите целевые листы на [A2] вместо A1, вы начнете вставлять во 2-ю строку ...

Надеюсь, это поможет

Удачи MikeD

после принятия редактирования

Что не так:

Очевидно, основная причина заключается в том, что UsedRange.Rows.Count возвращает 1 для пустого листа (по крайней мере, в Excel 2003), что может оказаться неожиданным. Это означает, что при записи в ...UsedRange.Rows.Count + 1 ваша первая запись вставляется в строку № 2 пустого листа. К сожалению, с одной строкой на листе (в строке № 2 или в другом месте) вы получите тот же результат, который заставляет 2-ю запись данных перезаписывать первую и т. Д., Поскольку количество строк никогда не увеличивается.

Я проверил это с помощью отладки через этот маленький

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