两表引用，类似于函数中的万金油,求大佬帮忙看看

阿哩木

具体需求在表格中，函数又做不到想要的结果。在此求助大佬帮忙看看，感谢感谢！！

英哲

Sub 两表引用()
With ThisWorkbook.Sheets(2)
Set connet = CreateObject("adodb.Connection") '创建对象变量
Set rst = CreateObject("ADODB.Recordset") '创建对象变量
con = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & ThisWorkbook.FullName & ";" & _
               "Extended Properties=Excel 12.0"
connet.Open con

S1 = "(SELECT 日期 ,条码 ,品名,工号,姓名,柜组,金额,户名,票号 FROM [明细表$] )"

S2 = " SELECT 日期 ,条码 ,品名,工号,姓名,柜组,金额,户名,t1.票号 FROM  [查找$L:L] as t1 left outer join " & S1 & "as t2 on t1.票号=t2.票号"
rst.Open S2, connet
.Range("N5").CopyFromRecordset rst
End With
End Sub

英哲

Sub 两表引用()
With ThisWorkbook.Sheets(2)
Set connet = CreateObject("adodb.Connection") '创建对象变量
Set rst = CreateObject("ADODB.Recordset") '创建对象变量
con = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & ThisWorkbook.FullName & ";" & _
               "Extended Properties=Excel 12.0"
connet.Open con

S1 = "(SELECT 日期 ,条码 ,品名,工号,姓名,柜组,金额,户名,票号 FROM [明细表$] )"

S2 = " SELECT 日期 ,条码 ,品名,工号,姓名,柜组,金额,户名,t1.票号 FROM  [查找$L:L] as t1 left outer join " & S1 & "as t2 on t1.票号=t2.票号"
rst.Open S2, connet
  
.Range("N5").CopyFromRecordset rst

End With


End Sub

英哲

要先把票号放在L列，并变成竖的，像图片这样。

Sub 两表引用()
With ThisWorkbook.Sheets(2)
Set connet = CreateObject("adodb.Connection") '创建对象变量
Set rst = CreateObject("ADODB.Recordset") '创建对象变量
con = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source=" & ThisWorkbook.FullName & ";" & _
               "Extended Properties=Excel 12.0"
connet.Open con

S1 = "(SELECT 日期 ,条码 ,品名,工号,姓名,柜组,金额,户名,票号 FROM [明细表$] )"

S2 = " SELECT 日期 ,条码 ,品名,工号,姓名,柜组,金额,户名,t1.票号 FROM  [查找$L:L] as t1 left outer join " & S1 & "as t2 on t1.票号=t2.票号"
rst.Open S2, connet

.Range("N5").CopyFromRecordset rst
End With
End Sub

3190496160

Sub 查询()
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim rn As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("明细表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "明细表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, 11))
End With
With Sheets("查找")
    Set rn = .Range("o1:v2")
    For Each c In rn
        If c.Value <> "" Then
            d(c.Value) = ""
            m = m + 1
        End If
     Next c
     If m = "" Then MsgBox "至少输入一个票号！": End
     ReDim br(1 To UBound(ar), 1 To 9)
     For i = 2 To UBound(ar)
        If ar(i, 10) <> "" Then
            If d.exists(ar(i, 10)) Then
                n = n + 1
                For j = 2 To 10
                    br(n, j - 1) = ar(i, j)
                Next j
            End If
        End If
    Next i
    If n = "" Then MsgBox "没有需要查询的票号": End
    rs = .Cells(Rows.Count, 14).End(xlUp).Row
    If rs >= 5 Then .Range("n5:v" & rs).Borders.LineStyle = 0: .Range("n5:v" & rs) = Empty
    .[n5].Resize(n, UBound(br, 2)) = br
    .[n5].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160

两表引用.rar (27.49 KB, 下载次数: 21)

2024-2-23 11:27 上传

点击文件名下载附件

3190496160

题外话：工作表内单元格边框一设到底是最糟糕的习惯，会增加文件体积，拖慢文件反应速度的

阿哩木

3190496160 发表于 2024-2-23 11:27

感谢感谢，太强了！！

阿哩木

3190496160 发表于 2024-2-23 11:28
题外话：工作表内单元格边框一设到底是最糟糕的习惯，会增加文件体积，拖慢文件反应速度的

怪不得，有时候我的表会很卡，我一直以为是表里公式太多的原因！！谢谢您，立刻马上去把它取消！！

yynrzwh

两表引用.rar (84.11 KB, 下载次数: 18)

2024-2-23 11:31 上传

点击文件名下载附件