按需提取供应商报价

wqhsz385919

早上好！

请帮忙看下 ，按需要提取供应商报价，按每行有4个供 应商报价，根据单价大小按同一行A列（提时判断分高与低）提取供应商单价，币种 ，供应商名称，自己琢磨半天，结果总是不对，故请教大侠，谢谢！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a2:p" & r)
   
7.         For i = 1 To UBound(arr)
   
8.             n = 0
   
9.             For j = 5 To UBound(arr, 2) Step 3
   
10.                 If Len(arr(i, j)) <> 0 Then
    
11.                     If n = 0 Then
    
12.                         n = j
    
13.                     Else
    
14.                         If arr(i, 1) = "高" Then
    
15.                             If arr(i, n) < arr(i, j) Then
    
16.                                 n = j
    
17.                             End If
    
18.                         Else
    
19.                             If arr(i, n) > arr(i, j) Then
    
20.                                 n = j
    
21.                             End If
    
22.                         End If
    
23.                     End If
    
24.                 End If
    
25.             Next
    
26.             If n <> 0 Then
    
27.                 arr(i, 2) = arr(i, n)
    
28.                 arr(i, 3) = arr(i, n + 1)
    
29.                 arr(i, 4) = arr(i, n + 2)
    
30.             End If
    
31.         Next
    
32.         .Range("a2:p" & n) = arr
    
33.     End With
    
34. End Sub
    

复制代码

chxw68

详见附件。

quqiyuan

参与一下，感觉稍微有点啰嗦样子，不过结果还好，仅供参考。。。

quqiyuan

代码如下。。。
Private Sub CommandButton1_Click()
arr = Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr) - 1, 1 To 3)
hl = [a1].Value
For i = 2 To UBound(arr)
    bj = Empty
    For j = 5 To UBound(arr, 2) Step 3
       If arr(i, j) <> "" Then

          arr(i, j) = IIf(arr(i, j + 1) = "USD", arr(i, j) * hl, arr(i, j))
            If arr(i, 1) = "高" Then
                If bj <> Empty Then
                    If bj < arr(i, j) Then
                        brr(i - 1, 1) = arr(i, j)
                        brr(i - 1, 2) = arr(i, j + 1)
                        brr(i - 1, 3) = arr(i, j + 2)
                    End If
                Else
                    bj = arr(i, j)
                    brr(i - 1, 1) = arr(i, j)
                    brr(i - 1, 2) = arr(i, j + 1)
                    brr(i - 1, 3) = arr(i, j + 2)
                End If
            Else
                If bj <> Empty Then
                    If bj > arr(i, j) Then
                        brr(i - 1, 1) = arr(i, j)
                        brr(i - 1, 2) = arr(i, j + 1)
                        brr(i - 1, 3) = arr(i, j + 2)
                    End If
                Else
                    bj = arr(i, j)
                    brr(i - 1, 1) = arr(i, j)
                    brr(i - 1, 2) = arr(i, j + 1)
                    brr(i - 1, 3) = arr(i, j + 2)
                End If
            End If
         End If
     Next
Next
    [b2].Resize(UBound(brr), 3) = brr
    Beep
End Sub

wqhsz385919

chxw68 发表于 2024-9-15 07:50
详见附件。

谢谢您！上面这个代码是我学习您的代码加了2句，但实际效果还是学习不到您的方法
就是我想币种是USD的要乘以汇率（A1单元格的值）再进行比较
比较完后，要恢复原来的数据，不改变源数据，

请您再看下，耽误您宝贵时间了，多谢！

chxw68

修改好了。

wqhsz385919

chxw68 发表于 2024-9-15 10:07
修改好了。

再次谢谢大侠，结果正确！
我没花了，明天给您补！