第一个表操作第二个表里的数据粘贴到第三个表指定位置，是难还是易？（已解决）

bbskill

我的表格是2007版的，但在软件中导出的是2003版的表格文件


问题：想用一个空表，操作第二个表中的数据，

复制粘贴到与第二个表中对应林场、林班、小班，的第三张表内对应位置

详情见图片和附件！

请各位大侠看一下应该如何弄，小弟在此先谢过了！！！！

yylucke

你可以了解学习自带函数SUMIFS，可解决。这样不用编程。

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()   '//2024.11.13
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Dim tm: tm = Timer
   
7.     f = p & "双丰导出因子表.xls"
   
8.     Set wb = Workbooks.Open(f, 0)
   
9.     arr = wb.Sheets("Sheet1").UsedRange
   
10.     wb.Close 0
    
11.     For i = 2 To UBound(arr)
    
12.         s = arr(i, 6) & "|" & arr(i, 10) & "|" & arr(i, 12)
    
13.         d(s) = Array(arr(i, 224), arr(i, 225))
    
14.     Next
    
15.     f = p & "双丰批次_总表.xls"
    
16.     Set wb = Workbooks.Open(f, 0)
    
17.     For Each sht In wb.Sheets
    
18.         If InStr(sht.Name, "采伐") Then
    
19.             With sht
    
20.                 arr = .UsedRange
    
21.                 For i = 2 To UBound(arr)
    
22.                     s = arr(i, 1) & "|" & arr(i, 3) & "|" & arr(i, 5)
    
23.                     If d.exists(s) Then
    
24.                         arr(i, 19) = d(s)(0)
    
25.                         arr(i, 20) = d(s)(1)
    
26.                     End If
    
27.                 Next
    
28.                 .UsedRange = arr
    
29.             End With
    
30.         End If
    
31.     Next
    
32.     wb.Close 1
    
33.     Set d = Nothing
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
36. End Sub
    
37. 
    

复制代码

3190496160

Sub 匹配()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "双丰导出因子表.xls*")
If f = "" Then MsgBox "找不到双丰导出因子表文件，请核查后重试！": End
Set wb = Workbooks.Open(lj & f, 0)
With wb.Worksheets(1)
    r = .Cells(Rows.Count, 6).End(xlUp).Row
    If r < 2 Then MsgBox "双丰导出因子表为空！": End
    ar = .Range("a1:hr" & r)
End With
wb.Close False
For i = 2 To UBound(ar)
    If ar(i, 6) <> "" And ar(i, 10) <> "" And ar(i, 12) <> "" Then
        s = ar(i, 6) & "|" & ar(i, 10) & "|" & ar(i, 12)
        d(s) = i
    End If
Next i
Set f = Nothing
f = Dir(lj & "双丰批次_总表.xls*")
If f = "" Then MsgBox "找不到双丰批次_总表文件，请核查后重试！": End
Set wb = Workbooks.Open(lj & f, 0)
With wb.Worksheets("采伐调查设计总表(CFDCSJZB)")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    If rs < 5 Then MsgBox "采伐调查设计总表(CFDCSJZB)！": End
    br = .Range("a4:t" & rs)
    For i = 2 To UBound(br)
        If br(i, 1) <> "" And br(i, 3) <> "" And br(i, 5) <> "" Then
            s = br(i, 1) & "|" & br(i, 3) & "|" & br(i, 5)
            xh = d(s)
            If xh <> "" Then
                br(i, 19) = ar(xh, 224)
                br(i, 20) = ar(xh, 225)
            End If
        End If
    Next i
    .Range("a4:t" & rs) = br
End With
With wb.Worksheets("采伐证申请表(CFZSQB)")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    If rs < 5 Then MsgBox "采伐证申请表(CFZSQB)为空！": End
    br = .Range("a4:v" & rs)
    For i = 2 To UBound(br)
        If br(i, 3) <> "" And br(i, 4) <> "" And br(i, 6) <> "" Then
            s = br(i, 3) & "|" & br(i, 4) & "|" & br(i, 6)
            xh = d(s)
            If xh <> "" Then
                br(i, 21) = ar(xh, 224)
                br(i, 22) = ar(xh, 225)
            End If
        End If
    Next i
     .Range("a4:v" & rs) = br
End With
wb.Close True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

新建文件夹.rar (49.51 KB, 下载次数: 3)

2024-11-13 14:54 上传

点击文件名下载附件

kyxfyzg

试试看。。。。。。。。

bbskill

首先谢谢三位大侠们的答惑解疑，经过数据实验，3190496160和kyxfyzg这两位大侠达到了目的，第一位大侠，只填写了“采伐调查设计总表”表中的内容，”采伐证申请表“数据为空！
再一次感谢三位大侠的回答！！