一张表中指定日期，在另一表按日期筛选非空白项目，复制区域内容粘贴到第1张表中。

lxm7751 · 发表于 2024-10-21 10:54

各位老师：
大家好！
我是vba一小白，之前在网站中学习用过简单的VBA复制粘贴，这次由于工作量比较大，需要重复很多个表，有时会复制粘贴错误，所以想简化操作方法避免错误的发生，但这个需要选择日期筛选，我之前学习过的太过浅薄，无法得到想要的结果。
麻烦老师们出手帮帮忙。
两张表格已附上传

excel玉米 · 发表于 2024-10-21 11:39

autohotey · 发表于 2024-10-21 11:39

将提取表更改为启用宏工作薄，将代码粘贴进去。然后在表格中插入图形，将图形指定该宏

Sub copydata()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim searchValue As String
Dim lastRow1 As Long, lastRow2 As Long
Dim i As Long, j As Long
Dim found As Boolean
Set wb1 = Workbooks("交纳数据提取.xlsm")
Set wb2 = Workbooks("订单交纳.xlsx")
Set ws1 = wb1.Sheets("交纳数量提取")
Set ws2 = wb2.Sheets("订单交纳")
lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
If lastRow1 > 1 Then
ws1.Rows("2:" & lastRow1).ClearContents
End If
searchValue = ws1.Range("L1").Value
found = False
For i = 1 To ws2.Rows(1).Cells.Count
If ws2.Cells(1, i).Value = searchValue Then
found = True
Exit For
End If
Next i
If found Then
lastRow2 = ws2.Cells(ws2.Rows.Count, i).End(xlUp).Row
lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row + 1
For j = 2 To lastRow2
If ws2.Cells(j, i).Value <> "" Then
ws1.Cells(lastRow1, "B").Resize(1, 10).Value = ws2.Cells(j, "B").Resize(1, 10).Value
ws1.Cells(lastRow1, "L").Value = ws2.Cells(j, i).Value
lastRow1 = lastRow1 + 1
End If
Next j
Else
MsgBox "在“订单交纳”表中首行未找到对应日期"
End If
End Sub

复制代码

lxm7751 · 发表于 2024-10-21 13:03

excel玉米发表于 2024-10-21 11:39

谢谢老师，需求完全解决，可以选择不同文件。谢谢

lxm7751 · 发表于 2024-10-21 13:04

autohotey 发表于 2024-10-21 11:39
将提取表更改为启用宏工作薄，将代码粘贴进去。然后在表格中插入图形，将图形指定该宏

谢谢老师，非常好用，解决了大难题，谢谢

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

[求助] 一张表中指定日期，在另一表按日期筛选非空白项目，复制区域内容粘贴到第1张表中。