根据数值复制多个工作表中的行

Question

我有多个销售工作表，其中销售人员提供其他东西，他们对某个销售的信心水平。我刚刚开始学习VBA，所以我并不是一无所知，但我不得不承认这是我的头脑。

如果某行的置信度超过60％，我希望将整行复制到新工作表中。

数据从第8行开始，置信度百分比列在第V列。

我希望将VBA脚本应用到总共9个工作表，它们被命名为：

• 杰夫
• 约翰
• 蒂姆
• 皮特
• 乍得
• 鲍勃
• 凯文
• 麦克
• 比尔

我希望置信度超过60％的所有行都复制到主页或“安装”表，再次从第8行开始。我想通过“安装”表单上的按钮运行脚本。 / p>

以下是我正在使用的图片：

Answer 1

以下代码

• 将所有九张纸（如果名称存在）中的第8行复制到名为“安装”的工作表
• 任何低于60％的记录都会自动过滤并从主表中删除（比复制前自动过滤九张纸的效率更高）
• 在顶部添加空白行以在第8行开始“安装”

*如果您确实需要第1行到第7行的标题行，那么可以从其中一个推销员表中复制这些行 - 请告诉我*

Sub QuickCombine()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim strShts()
Dim strWs As Variant
Dim lngCalc As Long

With Application
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With

Set ws1 = Sheets("Install")
ws1.UsedRange.Cells.Clear

strShts = Array("Jeff", "John", "Tim", "Pete", "Chad", "Bob", "Kevin", "Mike", "Bill")
For Each strWs In strShts
On Error Resume Next
Set ws2 = Sheets(strWs)
On Error GoTo 0
If Not ws2 Is Nothing Then
Set rng1 = ws2.Range(ws2.[v8], ws2.Cells(Rows.Count, "v").End(xlUp))
rng1.EntireRow.Copy ws1.Cells(ws1.Cells(Rows.Count, "v").End(xlUp).Offset(1, 0).Row, "A")
End If
Set ws2 = Nothing
Next
With ws1
    .[v1] = "dummy"
    .Columns("V").AutoFilter Field:=1, Criteria1:="<60%"
    .Rows.Delete
.Rows("1:7").Insert
End With
With Application
.ScreenUpdating = True
.Calculation = lngCalc
End With
End Sub