VBA

Question

早上好！

我正在尝试：

1 - 循环所有我的 sheets，从第 2 个 sheet 开始（直到它开始工作）；

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

3 - 现在，在每个 sheet 和同一个循环中，我需要在 F 列中搜索该列的所有值 <= iQ1（并为其他间隔 (iQ) 创建其他条件）。例如，如果循环中的这些值 <=Q1，我需要将所有这些值及其数量（G 列）复制并粘贴到 J2:J 列（为了兴趣）和 K2:K（为了数量）。我创建一张图片来更好地解释。

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

我只为 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

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

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

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 一如既往地进行操作的工作 sheet。请注意此处的 With 语句，并始终确保在您对 Range 或 Cells 的引用前加上点 . 以确保它正在处理 ws 工作sheet.

接下来，最好在靠近首次使用变量的地方声明变量，并将每个变量放在各自的行中。这当然可以是个人喜好，但这是目前最普遍的习惯。

您的内部循环不起作用的地方在于您引用不同数据的方式。在我下面的示例中，每个四分位数范围都被明确定义。此外，我使用更具描述性的变量名称来指示我当前正在处理的数据。最后，为了展示如何在 function/sub.

中隔离公共代码部分，更容易分解一个单独的例程将兴趣数据附加到特定的四分位数中。

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

VBA - Copy/paste 2 行块（如果满足一行的条件）

VBA - Copy/paste 2 blocks of rows if condition to one row is met

excel

loops

copy-paste