VBA - 如果满足一行的条件，则复制/粘贴 2 行块

Question

早上好！

我正在尝试：

1 - 循环我的所有工作表，从第二张工作表开始（直到它工作）；

2 - 求最大值、最小值和区间（Max-Min Value/4），分配给单元格，再定义 3 个区间 iQ1、iQ2 和 iQ3。这样我得到了构建 4 个分位数所需的所有间隔（直到这里它也可以工作）；

3 - 现在，在每个工作表和同一个循环中，我需要在 F 列中搜索

我需要这个，因为之后我需要计算每个分位数的中位数。

我只为 F 列尝试了第一个循环，但它失败了这个和我尝试的其他事情。请您帮我解决第 3 项，好吗？

谢谢，祝你有美好的一天！

Application.ScreenUpdating = False

Dim ws2 As Worksheet
Dim x As Long, Interval As Double, MaxValue As Double, MinValue As Double, iQ1 As Double, iQ2 As Double, iQ3 As Double, rw2 As Object

For x = 2 To Sheets.Count
    Sheets(x).Activate
    
    Dim c As Range
    Set c = Range("F2:F" & Rows.Count)
        MaxValue = Application.WorksheetFunction.Max(c)
        MinValue = Application.WorksheetFunction.Min(c)
        Interval = (MaxValue - MinValue) / 4
        Sheets(x).Range("I2").Value = Interval
        Sheets(x).Range("P2").Value = MaxValue
        Sheets(x).Range("O2").Value = MinValue
        Sheets(x).Range("J2:M500000").Clear
        iQ1 = MinValue + Interval
        iQ2 = iQ1 + Interval
        iQ3 = iQ2 + Interval
        
        For Each rw2 In Sheets(x).Range(c) 'Here is the loop that I'm stucked
            If rw2.Cells(6).Value <= iQ1 Then 'Here is the condition blue for F, it's in the picture 
                With Sheets(x)
                rw2.EntireRow.Copy
                .Cells(.Rows.Count, "J2:J").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End With
            End If
        Next rw2

Next x

Application.ScreenUpdating = True

Answer 1

您的结构几乎正确，希望以下几点能帮助您保持正确。

首先，您可以使用此处的示例更简单地遍历工作簿中的所有工作表，包括在需要时跳过特定工作表：

Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
    If Not ws.Name = "SKIP THIS SHEET" Then
        With ws
            ...
        End With
    End If
Next ws

使用这样的循环，您可以放心 ws 一如既往地操作工作表。请注意此处的 With 声明，并始终确保在您对 Range 或 Cells 的引用前加上点 .，以确保它在 ws 工作表上工作。

接下来，最好将变量声明在靠近它们首次使用的位置，并将每个变量放在自己的行上。这当然可以是个人喜好，但这是目前最常见的习惯。

您的内部循环不起作用的地方是您引用不同数据的方式。在下面的示例中，每个 Quatil 范围都已明确定义。此外，我使用更具描述性的变量名称来指示我当前正在处理的数据。最后，更容易分解出一个单独的例程来将兴趣数据附加到特定的 quartil 中，以显示如何在函数/子中隔离常见的代码部分。

Option Explicit

Sub test()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
        If Not (ws.Name = "SKIP THIS SHEET") Then
            With ws
                Dim interestData As Range
                Dim lastRow As Long
                lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
                Set interestData = .Range("F2:F" & lastRow)
                
                Dim Interval As Double
                Dim MaxValue As Double
                Dim MinValue As Double
                Dim iQ1 As Double
                Dim iQ2 As Double
                Dim iQ3 As Double
                MaxValue = Application.WorksheetFunction.Max(interestData)
                MinValue = Application.WorksheetFunction.Min(interestData)
                Interval = (MaxValue - MinValue) / 4
                .Range("I2").Value = Interval
                .Range("R2").Value = MaxValue
                .Range("S2").Value = MinValue
                .Range("J2:Q500000").Clear
                iQ1 = MinValue + Interval
                iQ2 = iQ1 + Interval
                iQ3 = iQ2 + Interval
                Debug.Print "Quartil 1: <= " & Format(iQ1, "000.000")
                Debug.Print "Quartil 2:  > " & Format(iQ1, "000.000") & ", <= " & Format(iQ2, "000.000")
                Debug.Print "Quartil 3:  > " & Format(iQ2, "000.000") & ", <= " & Format(iQ3, "000.000")
                Debug.Print "Quartil 4: => " & Format(iQ3, "000.000")
                
                Dim q1 As Range
                Dim q2 As Range
                Dim q3 As Range
                Dim q4 As Range
                Set q1 = .Range("J2")
                Set q2 = .Range("L2")
                Set q3 = .Range("N2")
                Set q4 = .Range("P2")
                
                Dim interestValues As Variant
                For Each interestValues In interestData
                    If (interestValues.Value <= iQ1) Then
                        AppendInterest q1, interestValues
                    ElseIf (interestValues.Value > iQ1) And (interestValues.Value <= iQ2) Then
                        AppendInterest q2, interestValues
                    ElseIf (interestValues.Value > iQ2) And (interestValues.Value <= iQ3) Then
                        AppendInterest q3, interestValues
                    Else    'interestValues > iQ3
                        AppendInterest q4, interestValues
                    End If
                Next interestValues
            End With
        End If
    Next ws
End Sub

Private Sub AppendInterest(ByRef quartil As Range, _
                           ByVal interest As Range)
    '--- copies the data in to the first empty row of the
    '    quartil group
    Dim lastRow As Long
    With quartil.Parent  'this is the worksheet
        lastRow = .Cells(.Rows.Count, quartil.Column).End(xlUp).Row
        quartil.Cells(lastRow, 1).Value = interest.Cells(1, 1).Value  'interest
        quartil.Cells(lastRow, 2).Value = interest.Cells(1, 2).Value  'qty
    End With
End Sub