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

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

20002024
20052028
974021
94 / 1.1.03
93 / 5.02
981017

我只想导出年份旁边有1的行。 所以981019是，982016 NO。 90 / 1.1.04是，91 / 5.01 NO。 为了解决这个问题，我想我需要检查单元是否包含一个“/”，如果这样的话复制单元格，如果/是“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*"将工作。 这显然没有。 这也是非常…慢。 所以我觉得我做错了什么。

任何想法如何做到这一点？ 如果我find了，我会提示让人们select要分开的号码。 谢谢。

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

其实你的代码应该如下所示。 请用您的目的地名称replaceSheet2。

 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