请高手写个提取数据的代码。内容见附件

三票

请高手写个提取数据的代码。内容见附件

duquancai

手机看不见附件中的内容，咋办？

gdszczh

请看附件中的表格”含代码“，点击”提取“按钮。

Sub 提取()
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
     For j = 1 To Cells(Rows.Count, 10).End(xlUp).Row
       If Cells(i, 2) = Cells(j, 10) And _
           Cells(i, 3) = Cells(j, 11) And _
           Cells(i, 4) = Cells(j, 12) And _
           Cells(i, 5) = Cells(j, 13) And _
           Cells(i, 6) = Cells(j, 14) And _
           Cells(i, 7) = Cells(j, 15) And _
           Cells(i, 8) = Cells(j, 16) Then
           n = n + 1
           Cells(n, 18) = Cells(i, 2)
           Cells(n, 19) = Cells(i, 3)
           Cells(n, 20) = Cells(i, 4)
           Cells(n, 21) = Cells(i, 5)
           Cells(n, 22) = Cells(i, 6)
           Cells(n, 23) = Cells(i, 7)
           Cells(n, 24) = Cells(i, 8)
           Exit For
       End If
    Next
Next
End Sub

tudarong

gdszczh 发表于 2018-7-15 15:49
请看附件中的表格”含代码“，点击”提取“按钮。

Sub 提取()

代码简单粗暴，但也不失为一种有效的方法，值得肯定！

jiminyanyan

Sub test()
  ' QQ 494585639
    Dim r%, i%
    Dim str
     Dim arr, brr
     Dim crr(1 To 10000, 1 To 7)
     Dim d As Object
     Set d = CreateObject("scripting.dictionary")
     With Worksheets("Sheet1")
       r = .Cells(.Rows.Count, 2).End(xlUp).Row
       arr = .Range("b1:h" & r)
       For i = 1 To UBound(arr)
           str = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6) & "," & arr(i, 7)
          d(str) = ""
       Next
       r = .Cells(.Rows.Count, 10).End(xlUp).Row
        brr = .Range("j1:p" & r)
        For i = 1 To UBound(brr)
           str = brr(i, 1) & "," & brr(i, 2) & "," & brr(i, 3) & "," & brr(i, 4) & "," & brr(i, 5) & "," & brr(i, 6) & "," & brr(i, 7)
           If d.exists(str) Then
                m = m + 1
                For j = 1 To 7
                    crr(m, j) = brr(i, j)
                Next
           End If
        Next
        .Range("r1:x10000").ClearContents
        .Range("r1").Resize(UBound(crr), 7) = crr
     End With
End Sub

jiminyanyan

.........

hopeson2010

1. Sub ek_sky()
   
2.    Dim arr As Variant, brr As Variant, crr As Variant
   
3.    Dim i As Integer, j As Integer, k As Byte, L As Integer, m As Integer, n As Byte
   
4.       arr = Range("B1:H" & Cells(Rows.Count, 2).End(xlUp).Row)
   
5.       brr = Range("J1:P" & Cells(Rows.Count, "j").End(xlUp).Row)
   
6.       ReDim crr(1 To UBound(arr), 1 To 7)
   
7.       For i = 1 To UBound(arr)
   
8.          For j = 1 To UBound(brr)
   
9.                   L = 0
   
10.             For k = 1 To 7
    
11.                If arr(i, k) = brr(j, k) Then
    
12.                  L = L + 1
    
13.                End If
    
14.             Next k
    
15.             If L = 7 Then
    
16.               m = m + 1
    
17.               For n = 1 To 7
    
18.                  crr(m, n) = arr(i, n)
    
19.               Next n
    
20.             End If
    
21.          Next j
    
22.       Next i
    
23. Range("R1").Resize(m, 7) = crr
    
24. End Sub

复制代码

chis3

Option Explicit
Sub test()
    Dim dic As Object, arr, brr, i As Byte, j As Integer, k As Integer, l As Integer, crr(1 To 10000, 1 To 7)
    Set dic = CreateObject("scripting.dictionary")
    arr = [b1].CurrentRegion: brr = [j1].CurrentRegion
    For i = 1 To UBound(arr, 2)
        For j = 1 To UBound(arr)
            dic(arr(j, i)) = ""
        Next j
        For j = 1 To UBound(brr)
            If dic.exists(brr(j, i)) Then
                k = k + 1
                crr(k, i) = brr(j, i)
                If k > l Then l = k
            End If
        Next j
        k = 0
        dic.removeall
    Next i
    [r5].Resize(l, 7) = crr
    set dic = nothing
End Sub

tudarong

jiminyanyan 发表于 2018-7-15 16:32
Sub test()
  ' QQ 494585639
    Dim r%, i%

将每一组数字合并成字符串后，装入字典，
然后利用字典的exists方法来比较，高。
对于初学VBA的我，长见识了。

chis3

chis3 发表于 2018-7-15 16:49
Option Explicit
Sub test()
    Dim dic As Object, arr, brr, i As Byte, j As Integer, k As Integer, ...

啊
我攪錯了
看了以為是按直行找相同的