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

lxm7751

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

excel玉米

autohotey

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

1. 
   
2. Sub copydata()
   
3.     Dim wb1 As Workbook, wb2 As Workbook
   
4.     Dim ws1 As Worksheet, ws2 As Worksheet
   
5.     Dim searchValue As String
   
6.     Dim lastRow1 As Long, lastRow2 As Long
   
7.     Dim i As Long, j As Long
   
8.     Dim found As Boolean
   
9.     Set wb1 = Workbooks("交纳数据提取.xlsm")
   
10.     Set wb2 = Workbooks("订单交纳.xlsx")
    
11.     Set ws1 = wb1.Sheets("交纳数量提取")
    
12.     Set ws2 = wb2.Sheets("订单交纳")
    
13.     lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    
14.     If lastRow1 > 1 Then
    
15.        ws1.Rows("2:" & lastRow1).ClearContents
    
16.     End If
    
17.     searchValue = ws1.Range("L1").Value
    
18.     found = False
    
19.     For i = 1 To ws2.Rows(1).Cells.Count
    
20.         If ws2.Cells(1, i).Value = searchValue Then
    
21.             found = True
    
22.             Exit For
    
23.         End If
    
24.     Next i
    
25.     If found Then
    
26.         lastRow2 = ws2.Cells(ws2.Rows.Count, i).End(xlUp).Row
    
27.         lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row + 1
    
28.         For j = 2 To lastRow2
    
29.             If ws2.Cells(j, i).Value <> "" Then
    
30.                 ws1.Cells(lastRow1, "B").Resize(1, 10).Value = ws2.Cells(j, "B").Resize(1, 10).Value
    
31.                 ws1.Cells(lastRow1, "L").Value = ws2.Cells(j, i).Value
    
32.                 lastRow1 = lastRow1 + 1
    
33.             End If
    
34.         Next j
    
35.     Else
    
36.         MsgBox "在“订单交纳”表中首行未找到对应日期"
    
37.     End If
    
38. End Sub
    

复制代码

lxm7751

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

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

lxm7751

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

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