指定行查询的问题

杨小妹

附件
指定行查询附件.rar (323.29 KB, 下载次数: 13)

2024-6-3 19:29 上传

点击文件名下载附件

谢谢老师！

wang-way

打开文件  然找行列号去取数不就行了

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.3
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     zrr = sh.[a1:b2]
   
6.     p = ThisWorkbook.Path & ""
   
7.     ReDim brr(1 To 1000, 1 To 2)
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase$(f.Name) Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 fn = fso.GetBaseName(f)
    
12.                 Set wb = Workbooks.Open(f, 0)
    
13.                 With wb.Sheets(1)
    
14.                     r = .Cells(Rows.Count, 1).End(3).Row
    
15.                     c = .UsedRange.Columns.Count
    
16.                     arr = .[a1].Resize(r, c)
    
17.                     wb.Close False
    
18.                 End With
    
19.                 For j = 1 To UBound(arr, 2)
    
20.                     For i = 1 To UBound(zrr)
    
21.                         If arr(zrr(i, 1), j) = zrr(i, 2) Then
    
22.                             m = m + 1
    
23.                             brr(m, 1) = fn
    
24.                             brr(m, 2) = 列号转列符(j)
    
25.                             Exit For
    
26.                         End If
    
27.                     Next
    
28.                 Next
    
29.             End If
    
30.         End If
    
31.     Next f
    
32.     With sh
    
33.         .[a4:b1000] = ""
    
34.         .[a4].Resize(m, 2) = brr
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "OK！"
    
38. End Sub
    
39. 
    

复制代码

gwjkkkkk

Option Explicit
Option Compare Text
Sub test()
    Dim strFileName$, strPath$, strName$
    Dim ar, br(), vResult, i&, j&, r&, k&
   
    Application.ScreenUpdating = False
    ar = [A1].CurrentRegion.Value
    ReDim vResult(1 To 10 ^ 3, 1)
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsb")
    Do Until strFileName = ""
        With GetObject(strPath & strFileName)
            r = r + 1
            ReDim Preserve br(1 To 2, 1 To r)
            br(1, r) = Split(.Name, ".xlsb")(0)
            br(2, r) = .Sheets(1).[A1].CurrentRegion.Value
            .Close False
        End With
        strFileName = Dir
    Loop
   
    r = 0
    For i = 1 To UBound(ar)
        For j = 1 To UBound(br, 2)
            For k = 1 To UBound(br(2, j), 2)
                If br(2, j)(ar(i, 1), k) = ar(i, 2) Then
                    r = r + 1
                    vResult(r, 0) = br(1, j)
                    vResult(r, 1) = ColumnLetter2(k)
                End If
            Next k
        Next j
    Next i
   
    [A4].CurrentRegion.Clear
    [A4].Resize(r, 2) = vResult
    Application.ScreenUpdating = True
    Beep
End Sub
Public Function ColumnLetter2(Column As Long) As String
    If Column < 1 Then Exit Function
    ColumnLetter2 = ColumnLetter2(Int((Column - 1) / 26)) & Chr(((Column - 1) Mod 26) + Asc("A"))
End Function

gwjkkkkk

请参考附件。。。

quqiyuan

供参考。。。

quqiyuan

代码。。。
Sub test()
Application.ScreenUpdating = False
Set wb = ThisWorkbook
arr = wb.Sheets(1).[a1].CurrentRegion
p = wb.Path
Set fso = CreateObject("scripting.filesystemobject")
ReDim crr(1 To 1000, 1 To 2)
For Each f In fso.getfolder(p).Files
    If f.Name Like "*.xls*" Then
        If InStr(f.Name, wb.Name) = 0 Then
            With Workbooks.Open(f, 0)
                brr = .Sheets(1).UsedRange
                r = UBound(brr)
                c = UBound(brr, 2)
                If arr(1, 1) > r Or arr(2, 1) > r Then Exit For
                For j = 1 To c
                    If brr(arr(1, 1), j) = arr(1, 2) And arr(2, 2) = brr(arr(2, 1), j) Then
                        n = n + 1
                        crr(n, 1) = Split(f.Name, ".xls")(0)
                        crr(n, 2) = Split(Cells(1, j).Address, "$")(1)
                    End If
                Next
                .Close 0
            End With
        End If
    End If
Next
wb.Sheets(1).[a10].CurrentRegion.Clear
wb.Sheets(1).[a10].Resize(n, 2) = crr
Application.ScreenUpdating = True
End Sub

杨小妹

gwjkkkkk 发表于 2024-6-3 20:09
请参考附件。。。

老师你好，谢谢帮助。试了一下，程序能正常运行。但返回的结果会多出很多错误的数据。比如：工作薄2  AC列中，456行是22  472行却30（应为26），说明此AC列，没有符合要求的数据，但返回的结果却有。还有重复出现返回的结果。

杨小妹

quqiyuan 发表于 2024-6-3 20:12
供参考。。。

老师你好，谢谢帮助。试了一下，运行错误。1004，错误指向第11行代码。