【求助】使用宏实现复制粘贴符合条件的数据

fsjs

在Sheet2中点击“华南”按钮，在Sheet1中C列查找“华南”单元格，复制对应E列和H列内容到Sheet2中的C列和D列，并按E列升序排列，E列金额有可能相同，相同金额随便哪个先，哪个后都可以。
请大神帮忙弄一下。

败不馁

Sub t()
Dim arr, arr2
arr = Range("c2").CurrentRegion.Value
x = Application.CountIf(Range("c2:c" & UBound(arr, 1)), "华南")
ReDim arr2(1 To x, 1 To 3)
For i = 1 To UBound(arr)
    If arr(i, 1) = "华南" Then
        k = k + 1
        arr2(k, 1) = arr(i, 3)
        arr2(k, 2) = arr(i, 6)
        arr2(k, 3) = arr(i, 7)
    End If
Next
Sheet2.Range("c3").Resize(UBound(arr2, 1), 3) = arr2
With Sheet2.Sort
    .SetRange Range("c3:e" & UBound(arr2, 1) + 3)
    .Apply
End With
End Sub

fsjs

败不馁 发表于 2018-12-29 09:36
Sub t()
Dim arr, arr2
arr = Range("c2").CurrentRegion.Value

大佬，提示“下标越界”
这句标黄了：
ReDim arr2(1 To x, 1 To 3)

败不馁

fsjs 发表于 2018-12-29 09:57
大佬，提示“下标越界”
这句标黄了：
ReDim arr2(1 To x, 1 To 3)

那你没有华南了，我没有判断你没有华南的情况

fsjs

败不馁 发表于 2018-12-29 10:13
那你没有华南了，我没有判断你没有华南的情况

该怎么修改呀。

败不馁

在x=下面添加if x=0 then exit sub

fsjs

败不馁 发表于 2018-12-29 10:32
在x=下面添加if x=0 then exit sub

点后没有报异常，但是数据没有粘贴过来。
Sub 按钮1_Click()
Dim arr, arr2
arr = Range("c2").CurrentRegion.Value
x = Application.CountIf(Range("c2:c" & UBound(arr, 1)), "华南")
If x = 0 Then Exit Sub
ReDim arr2(1 To x, 1 To 3)
For i = 1 To UBound(arr)
    If arr(i, 1) = "华南" Then
        k = k + 1
        arr2(k, 1) = arr(i, 3)
        arr2(k, 2) = arr(i, 6)
        arr2(k, 3) = arr(i, 7)
    End If
Next
Sheet2.Range("c3").Resize(UBound(arr2, 1), 3) = arr2
With Sheet2.Sort
    .SetRange Range("c3:e" & UBound(arr2, 1) + 3)
    .Apply
End With

End Sub

败不馁

fsjs 发表于 2018-12-29 10:38
点后没有报异常，但是数据没有粘贴过来。
Sub 按钮1_Click()
Dim arr, arr2

那肯定阿，你都没华南阿

fsjs

败不馁 发表于 2018-12-29 10:48
那肯定阿，你都没华南阿

哥们儿，能帮我附件编辑一下吗