Question

我的代码存在一些问题，我们将非常感谢您的帮助。

我在一个名为Wheel Diameters的选项卡中有一系列数据，我需要满足以下条件（B6到B28，G，L列必须小于4000，单元格值必须小于或等于800）第二个是（B35至B54列，G，L需要大于4000但小于5000且单元格值需要为800或更小）第三个是（B61至B92列，G，L需要为9000或将信息提升到另一个名为Wheel Diameters league的标签中，更大且单元格值必须为800或更小。

小于4000需要进入A和B列的车轮直径联合选项卡，大于4000但小于5000需要进入D和E列，大于9000需要进入G列和小时。

Sub BUTTON5_Click()

Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet

'Change worksheet designations as needed
 Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")

Target.Range("A2:B5000").Clear

j = 2     ' Start copying to row 2 in target sheet

For i = 1 To 3 'Number of ¿wees?
For Each c In Union(Source.Range(Cells(6, 5 * i - 2), Cells(28, 5 * i +    1)), Source.Range(Cells(35, 5 * i - 2), Cells(54, 5 * i + 1)), Source.Range(Cells(61, 5 * i - 2), Cells(92, 5 * i + 1)))

    If c.Text < 4000 And c.Text <= 800 Then

        Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
        Target.Cells(j, 2) = Source.Cells(5, c.Column)

       j = j + 1

    ElseIf c.Text <= 800 And c.Text >= 4000 Then

        Target.Cells(j, 4) = Source.Cells(c.Row, 5 * i - 3)
        Target.Cells(j, 5) = Source.Cells(5, c.Column)

       j = j + 1

    End If

Next c

Next i

End Sub

它的外观示例：

3405 - 由于大于800，第1栏和第3405栏的细节将被提升并复制到第二个名为“Wheel Diameters League”的标签中

Answer 1

这适用于您的示例数据：

Dim Source As Worksheet
Dim Target As Worksheet
Dim rg As Range
Dim x As Long, y As Long, z As Long, tcol As Long, threshold As Long

Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")

Set rg = Source.Range("B6:P92")

For x = 1 To rg.Columns.Count Step 5
    For y = 1 To rg.Rows.Count
        For z = 1 To 4

            Select Case rg.Cells(y, x)
                Case 0 To 3999
                    tcol = 2 ' column 'B'
                    threshold = 800
                Case 4000 To 8999
                    tcol = 5 ' column 'E'
                    threshold = 864
                Case Else
                    tcol = 8 ' column 'H'
                    threshold = 849
            End Select

            If rg.Cells(y, x + z) > 10 And rg.Cells(y, x + z) <= threshold Then
                    With Target.Cells(Rows.Count, tcol).End(xlUp)
                        .Offset(1, 0) = rg.Cells(y, x)      'write Coach No
                        .Offset(1, 1) = z                   'write Axle No
                        .Offset(1, 2) = rg.Cells(y, x + z)  'write value
                    End With
            End If
        Next z
    Next y
Next x

我添加了一个名为tcol的新变量，这是我们将联盟数据写入的目标列。我根据轴类创建了Select Case来确定它设置的列。

我已添加threshold，这也是基于轴类。

我已将范围扩展到P92以读取所有数据。

我已添加测试以确保价值高于10，而不是低于threshold。这样可以防止非轴数据但是标题的单元格触发写入联赛表格。

我已经为For.. Next和x更加动态y循环，以防你的表格改变大小 - 在这种情况下你只需要改变{{1}范围。

最后，我在写表的价值时加入了，因为我之前没有注意到这个要求。

VBA - 我需要从Excel工作表中提取特定数字并将其移动到另一个选项卡

1 个答案: