Question

我在Excel 2010中使用VBA创建一个宏，根据DOB和State单元格（所有在同一工作簿中）将行从一个工作表移动到另一个工作表。

宏检查DOB是否为“截止”日期，如果该行通过，该行应附加到TSP表并从Sheet1中删除。

如果它没有通过，那么它会检查该行的“状态”单元格是否存在状态表。如果是，则该行应附加到该表的末尾，并从Sheet1中删除。

如果该行不符合这两行中的任何一行，则只需手动检查，因为它丢失数据或数据输入不正确。

除了将行附加到工作表之外，所有工作都正常。它只是替换了工作表的最后一行，除了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()

我的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

所有其他工作表都是空白的，虽然我很想在第二行开始插入（或计数+ 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行，它放在Sheet2的第2行，留下1行空白（因为+1）。这个空行＃1对后来对UsedRange的调用造成了一些混淆，随后在第2行（日期条件）中的后续命中覆盖了第一个查找。

BTW第一个If Row >= 2 Then是多余的，因为环绕For无论如何都会设置边框。

我建议稍微重新编码整个Sub ....

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，那么您将开始插入第二行......

希望有所帮助

祝你好运MikeD

发布接受编辑

出了什么问题：

根本原因显然是UsedRange.Rows.Count为空表（至少在Excel 2003中）返回 1 ，这可能会出乎意料。这意味着通过写入...UsedRange.Rows.Count + 1，您的第一条记录将被插入空白表的第2行。不幸的是，如果工作表中有一行（在第2行或其他地方），您会得到相同的结果，这会使第二个数据记录覆盖第一个，依此类推，因为行数永远不会增加。

我通过调试遍历这个小的

进行了测试

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

Excel 2010 VBA - 不附加行

1 个答案: