提取

kyxfyzg

1. Sub text()
   
2. Dim rng As Range
   
3. Sheets("分配").Range("e2", Cells(Cells(Rows.Count, "c").End(xlUp).Row, "j")).ClearContents
   
4. arr = Sheets("存量").UsedRange
   
5. brr = WorksheetFunction.Transpose(WorksheetFunction.Index(arr, 0, 1))
   
6. For Each rng In Sheets("分配").Range("c2", Cells(Rows.Count, 3).End(xlUp))
   
7.     r = WorksheetFunction.Match(rng.Value, brr, 0)
   
8.     If r > 0 Then
   
9.         rng.Offset(0, 2) = arr(r, 2) + arr(r, 3)
   
10.         rng.Offset(0, 4) = arr(r, 2)
    
11.         rng.Offset(0, 5) = arr(r, 3)
    
12.     End If
    
13. Next
    
14. End Sub

复制代码

xiaomaoaini

正好需要，学习一下

680926

Sub t()
Dim arr, brr
arr = Sheets(1).UsedRange
brr = Sheets(2).Range("a1").CurrentRegion
For i = 2 To UBound(brr)
    For j = 2 To UBound(arr)
            If brr(i, 3) = arr(j, 1) Then
                For k = 2 To 3
                    If arr(j, k) <> "" Then
                        brr(i, 5) = arr(j, k)
                        If k = 2 Then
                            brr(i, 7) = arr(j, k)
                        Else
                            brr(i, 8) = arr(j, k)
                        End If
                    End If
                Next
            End If
    Next
Next
Range("a28").Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

ddz79101

笨鸟飞不高 发表于 2024-8-16 09:01

谢谢老师！运行成功

ddz79101

chxw68 发表于 2024-8-16 09:17
练习。。。

谢谢老师！运行成功！

ddz79101

kyxfyzg 发表于 2024-8-16 09:59

谢谢老师！无法运行， r = WorksheetFunction.Match(rng.Value, brr, 0)出错

ddz79101

680926 发表于 2024-8-16 10:48
Sub t()
Dim arr, brr
arr = Sheets(1).UsedRange

谢谢老师！没有提取！

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&
   
    Application.ScreenUpdating = False
    ar = [A1].CurrentRegion.Value
    br = Worksheets(1).[I1].CurrentRegion.Value
   
    For i = 2 To UBound(ar)
        For j = 2 To UBound(br)
            If br(j, 1) = ar(i, 3) Then
                ar(i, 5) = br(j, 2) & br(i, 3)
                If Len(br(j, 2)) Then
                    ar(i, 7) = br(j, 2)
                Else
                    ar(i, 8) = br(i, 3)
                End If
                Exit For
            End If
        Next j
    Next i
   
    [A1].CurrentRegion.Value = ar
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。。