指定日期，数据从表1中提取到表2

olin12345 · 发表于 2019-3-20 08:04

本帖最后由 olin12345 于 2019-3-20 19:13 编辑

求助说明：
1.表1是数据源表，表2是数据需求表，在表2中通过A1单元格输入日期，将表1中所有符合日期的数据提取到表2中
2.表2中提取的数据列不连续，如只提取数据表1中的第2列，第5列，第6列等（即提取列易于修改）

lsc900707 · 发表于 2019-3-20 08:23

用工作表事件：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim brr(1 To 99999, 1 To 10)
If Target.Address = "$A$1" Then
With Sheets("每日公司汇总")
r = .Cells(.Rows.Count, 1).End(3).Row
arr = .Range("a5:l" & r)
For i = 1 To UBound(arr)
If Trim(arr(i, 1)) = Target Then
m = m + 1
brr(m, 1) = arr(i, 2)
For j = 2 To 10
brr(m, j) = arr(i, j + 2)
Next
End If
Next
End With
End If
If m Then
[a1].CurrentRegion.Offset(2).Clear
[a3].Resize(m, UBound(brr, 2)) = brr
[a3].Resize(m, UBound(brr, 2)).Borders.LineStyle = 1
End If
End Sub

复制代码

lsc900707 · 发表于 2019-3-20 08:24

测试参考附件：

olin12345 · 发表于 2019-3-20 08:58

lsc900707 发表于 2019-3-20 08:23
用工作表事件：

感谢版主的帮助，有点小问题如下：
1.我把日期换成2019/3/20,这种格式的时候就不能提取了，表1中的数据源我也更换了
2.工作表事件就是触发是这样理解吗？因为我点A1时它才刷新，能不能改成按钮？
3.在论坛里看到过类似下面这样的结构，这种结构可调性比较简单，好像可以任意调想调取的列，刚接触的水平只有如此了
brr(n, 4) = arr(i, 6)
brr(n, 5) = arr(i, 7)
brr(n, 6) = arr(i, 8)
brr(n, 7) = arr(i, 9)
brr(n, 8) = arr(i, 10)
brr(n, 9) = arr(i, 11)
brr(n, 10) = arr(i, 12)

lsc900707 · 发表于 2019-3-20 09:26

olin12345 发表于 2019-3-20 08:58
感谢版主的帮助，有点小问题如下：
1.我把日期换成2019/3/20,这种格式的时候就不能提取了，表1中的数据 ...

可以自己学着修改一下的。

lsc900707 · 发表于 2019-3-20 10:35

olin12345 发表于 2019-3-20 08:58
感谢版主的帮助，有点小问题如下：
1.我把日期换成2019/3/20,这种格式的时候就不能提取了，表1中的数据 ...

Sub gj23w98()
Dim brr(1 To 99999, 1 To 10)
With Sheets("每日公司汇总")
r = .Cells(.Rows.Count, 1).End(3).Row
arr = .Range("a5:l" & r)
For i = 1 To UBound(arr)
If arr(i, 1) = [a1] Then
m = m + 1
brr(m, 1) = arr(i, 2)
brr(m, 7) = arr(i, 9)
brr(m, 8) = arr(i, 10)
End If
Next
End With
If m Then
[a1].CurrentRegion.Offset(2).Clear
[a3].Resize(m, UBound(brr, 2)) = brr
[a3].Resize(m, UBound(brr, 2)).Borders.LineStyle = 1
End If
End Sub

复制代码

lsdongjh · 发表于 2019-3-20 11:43

用ADO+SQL

Private Sub Worksheet_Change(ByVal Target As Range)
Dim strDate As String
If Target.Address(0, 0) = "A1" Then
strDate = Target.Value
SelectValByNum strDate
End If
End Sub
Function SelectValByNum(strDate As String)
Dim strShName As String, shData As Worksheet, shResult As Worksheet, lngRows As Long
Dim Conn As Object, Rst As Object, strPath As String
Dim strConn As String, strSQL As String
Dim rg As Range
strShName = "每日公司汇总"
Set shData = Sheets(strShName)
Set shResult = Sheets("个人每日明细")
lngRows = shData.Range("A" & Rows.Count).End(xlUp).Row
Set Conn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
strPath = ThisWorkbook.FullName
Select Case Application.Version * 1
Case Is <= 11
strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
Case Is >= 12
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=NO"";"""
End Select
Conn.Open strConn
'''''''''''''''''''''''''''''''''
strSQL = "SELECT [F2],[F4],[F5],[F6],[F7],[F8],[F9],[F10],[F11],[F12] " & _
"FROM [" & strShName & "$A4:L" & lngRows & "] " & _
"WHERE [F1] LIKE '" & strDate & "'"
Rst.Open strSQL, Conn, 3, 1 '执行查询，并将结果输出到记录集对象
shResult.Range("A3:J" & Rows.Count).Clear
Set rg = shResult.Range("A3")
rg.CopyFromRecordset Rst
Set Rst = Nothing
Set Conn = Nothing
End Function

复制代码

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

[已解决] 指定日期，数据从表1中提取到表2

评分

评分

评分