Excelmacros重复IF和其他

我目前正在一个Excel VBAmacros脚本中，它将在活动单元格中执行一个简单的TRUE或Falsetesting。 我的问题是，我不能使这个工作，直到名单的结尾。 它只运行一次，结束程序。 我需要这个VB脚本来执行到列表底部的IF＆ELSEtesting。

问题描述：

比方说，我有一个在A1到A9999的date列表，在它旁边（F1：F9999），还有一个列表上有一个文本。 F1：F9999列表只包含两个值。 （a）同一date和（b）不同。

1. 在列表F1：F9999中执行True或Falsetesting。

2. 如果活动单元格值等于文本“SAME DATE”（TRUE），它将忽略并移动到列表中的下一个项目，然后再次执行第1项。

3. 如果活动单元格值等于文本“SAME DATE”（FALSE），它将在其上插入一行，然后移动到列表中的下一个项目，然后再次执行数字1
4. TRUE或FALSEtesting将一直运行到列表的末尾。
5. 如果TRUE或FALSEtesting到达列表底部，它将停止运行。
6. 顺便说一下，列表中的项目数量是不一致的。 我只是把F1：F9999作为例子。

这是我的代码！

Sub IFandElseTest() If ActiveCell.Value = "Same Date" Then Range(Selection, Cells(ActiveCell.Row, 1)).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove ActiveCell.Offset(1, 0).Select Else: ActiveCell.Offset(1, 0).Select Range(Selection, Cells(ActiveCell.Row, 1)).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove End If End Sub 

Appreaciate，如果你能帮助我这一点。

Answer 1

试试这个。

说明：

1. 你应该避免使用.Select/ActiveCell等。你可能想看到这个链接
2. 在处理最后一行时，最好不要硬编码值，而是dynamic查找最后一行。 你可能想看到这个链接
3. 使用对象，如果当前工作表不是您要使用的工作表？
4. 下面的FOR循环将从下面遍历该行并向上移动。

码：

 Sub Sample() Dim ws As Worksheet Dim LRow As Long, i As Long Dim insertRange As Range '~~> Chnage this to the relevant sheet Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Work with the relevant sheet With ws '~~> Get the last row of the desired column LRow = .Range("E" & .Rows.Count).End(xlUp).Row '~~> Loop from last row up For i = LRow To 1 Step -1 '~~> Check for the condition '~~> UCASE changes to Upper case '~~> TRIM removes unwanted space from before and after If UCase(Trim(.Range("E" & i).Value)) = "SAME DATE" Then '~~> Insert the rows .Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove End If Next i End With End Sub 

截图：

跟进评论

它真的有效！ 但是，最后一个修改。 在你的代码中：Set ws = ThisWorkbook.Sheets（“Sheet1”）是否可以将WS设置为活动工作表。 这是因为工作表的名称是唯一的，也是不一致的。

就像我提到的，在上面的第一个链接以及注释中，不要使用Activesheet 。 使用不变的表单的CodeNames 。 请参阅下面的截图。

Blah Blah是您在工作表选项卡中看到的工作表的名称，但Sheet1是不会更改的CodeName 。 即你可以改变从Blah Blah表单的名称来说Kareen但在VBA编辑器中，你会注意到Codename不会改变:)

更改代码

 Set ws = ThisWorkbook.Sheets("Sheet1") 

至

 '~~> Replace Sheet1 with the relevant Code Name Set ws = [Sheet1] 

Answer 2

编辑 ：

如果你忽略了r.copy行，它或多或less就是Siddharth Rout的解决scheme

 Sub insrow() Dim v, r As Range Set r = [d1:e1] v = r.Columns(1).Value Do ' r.copy If v = "Same Date" Then r.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Set r = r.Offset(1) v = r.Columns(1).Value Loop Until v = "" End Sub 

如果行超过9999行，这还不包括结束条件，但应该很容易添加…