Excel VBA：以单元格中的特定数字格式复制行单元格

Question

我在xlsx中有一个acces导出文件，第一列是数字。 有两种类型的数字：（YY）YYXXXX和YY / X（.X）.XX
一些例子。

20002024
20052028
974021
94 / 1.1.03
93 / 5.02
981017

我只想导出年份旁边具有1的行。 所以981019是，982016否。 90 / 1.1.04是，91 / 5.01是 为此，我想我需要检查单元格是否包含“ /”，如果是，则在/旁边的数字为“ 1”时复制该单元格。 如果不是倒数第四个数字为1，则不导出该单元格。

Sub copyrows()

Dim tfCol As Range, Cell As Object

Set tfCol = Range("A:A")

For Each Cell In tfCol

    If InStr(1, Cell, "/", 1) Then
        If Cell.Value = "??/1*" Then


        Cell.EntireRow.Copy
        Sheet2.Select 'Substitute with your sheet
        ActiveSheet.Range("A65536").End(xlUp).Select
        Selection.Offset(1, 0).Select
        ActiveSheet.Paste
        End If

    ElseIf Cell.Value = "*1???" Then

    Cell.EntireRow.Copy
        Sheet2.Select 'Substitute with your sheet
        ActiveSheet.Range("A65536").End(xlUp).Select
        Selection.Offset(1, 0).Select
        ActiveSheet.Paste
    End If
Next

 End sub

该代码不起作用。 我真的怀疑整个If Cell.Value = "??/1*"是否If Cell.Value = "??/1*" 。 显然不是。 速度也很慢。 所以我想我做错了。

有关如何执行此操作的任何想法？ 如果发现此问题，我会提示您选择必须分隔的数字。 谢谢。

Answer 1

假设您的数据在A1到A5中

Sub copyrows()
    Dim tfCol As Range, Cell As Object
    Set tfCol = Range("A1:A5")
    For Each Cell In tfCol
        If InStr(Cell, "/") > 0 Then
            If Cell.Value Like "??/1*" Then
                Cell.EntireRow.Copy Sheet2.Range("A" & Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row + 1)
            End If
        ElseIf Cell.Value Like "*1???" Then
            Cell.EntireRow.Copy Sheet2.Range("A" & Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row + 1)
        End If
    Next
End Sub

编辑1

实际上，您的代码应如下所示。 请用您的目标工作表名称替换Sheet2。

Sub copyrows()
    Dim tfCol As Range, Cell As Object
    Set tfCol = Range("A1:A5")
    For Each Cell In tfCol
        If InStr(Cell, "/") > 0 Then
            If Cell.Value Like "??/1*" Then
                Cell.EntireRow.Copy Sheet2.Range("A" & Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row + 1)
            ElseIf Cell.Value Like "*1???" Then
                Cell.EntireRow.Copy Sheet2.Range("A" & Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row + 1)
            End If
        End If
    Next
End Sub