批量比对列数据提取序号的问题

杨小妹 · 发表于 2024-12-16 18:42

本帖最后由杨小妹于 2024-12-16 20:00 编辑

附件

批量比对列数据提取序号附件.rar (1.28 MB, 下载次数: 21)

谢谢老师！

ykcbf1100 · 发表于 2024-12-16 19:14

我没看懂。。。

chxw68 · 发表于 2024-12-16 19:28

Sub test()
Dim r&, i&
Dim arr, brr()
Dim wb As Workbook
Dim ws As Worksheet
Dim mypath$, myname$
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ThisWorkbook.Worksheets("sheet0")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:a" & r)
x = arr(UBound(arr), 1)
For i = 1 To UBound(arr)
If arr(i, 1) = x Then
d(i) = Empty
End If
Next
End With
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xlsb")
Do While myname <> ""
Set wb = GetObject(mypath & myname)
Windows(wb.Name).Visible = True
With wb
ReDim brr(1 To 10000, 1 To 2)
m = 0
With .Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For j = 1 To UBound(arr, 2)
For Each aa In d.keys
If aa <= UBound(arr) Then
If arr(aa, j) = x Then
m = m + 1
brr(m, 1) = aa
brr(m, 2) = j
End If
End If
Next
Next
End With
With .Worksheets("sheet2")
.Range("d1:e" & .Rows.Count).Clear
If m > 0 Then
.Range("d1").Resize(m, UBound(brr, 2)) = brr
End If
End With
.Close True
End With
myname = Dir
Loop
End Sub

复制代码

z865593849 · 发表于 2024-12-16 19:29

看不懂...........

gwjkkkkk · 发表于 2024-12-16 19:30

Option Explicit
Sub test()
Dim ar, br(), i&, j&, r&, n&, vTemp, strFileName$, strPath$

Application.ScreenUpdating = False

n = Cells(Rows.Count, "A").End(xlUp).Row - 1
vTemp = Cells(Rows.Count, "A").End(xlUp).Value

strPath = ThisWorkbook.Path & "\"
strFileName = Dir(strPath & "*.xlsb")
Do Until strFileName = ""
      With Workbooks.Open(strPath & strFileName)
         With .Worksheets(1)
            ar = .[A1].CurrentRegion.Value
            Erase br(): r = 0
            For j = 1 To UBound(ar, 2)
                  For i = 1 To n
                     If ar(i, j) = vTemp Then
                        r = r + 1
                        ReDim Preserve br(1 To 2, 1 To r)
                        br(1, r) = i: br(2, r) = j
                     End If
                  Next i
            Next j
            br = Application.Transpose(br)
         End With
         With .Worksheets(2)
            .Cells.Clear
            .[A1].Resize(UBound(br), 2) = br
         End With
         .Close True
      End With
      strFileName = Dir
Loop

Application.ScreenUpdating = True
Beep
End Sub

chxw68 · 发表于 2024-12-16 19:30

详见附件。

shiruiqiang · 发表于 2024-12-16 19:32

本帖最后由 shiruiqiang 于 2024-12-16 19:39 编辑

大致猜测，可能结果有点不同

shiruiqiang · 发表于 2024-12-16 19:33

gwjkkkkk · 发表于 2024-12-16 19:40

请参考。。。

蓝桥玄霜 · 发表于 2024-12-16 19:43

比对的例子：

		自动登录	找回密码
密码			免费注册

[已解决] 批量比对列数据提取序号的问题

评分

评分

评分

评分

评分