请大神们帮修改复制的问题

cmo9020

请大神们帮修改小弟有2个表(A.B工作簿)A表是主档,
要把B表Sheet2当天日期的数据(C到I)复制过来(以计算机系统日期为准，只复制当天日期)数据会一直往下key往下续增

但是现在我按执行不管几次，它就一直复制...
程序能变成A表复制B表中的当天笔数相同一致就好吗?
假设B表今天10笔数据~A表就复制10笔~
(如果遇到连续执行,不会在次增加额外笔数)
B表临时增加1笔,在执行后A表就只会增加1笔
test.rar (43.92 KB, 下载次数: 3)

2021-1-16 16:00 上传

点击文件名下载附件

Sub lqxs()
Dim arr, i&, wb As Workbook, myr&
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls*")
    Set wb = ThisWorkbook
        Do While f <> ""
        If f <> wb.Name And InStr(f, "B") Then
            Set wb = Workbooks.Open(p & f)                  
                    End If
        f = Dir()
    Loop
Sheet1.Activate
arr = wb.Sheets(1).[c1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 1) = Date Then
myr = Cells(Rows.Count, 3).End(xlUp).Row + 1
Cells(myr, 3).Resize(1, UBound(arr, 2)) = Application.Index(arr, i, 0)
wb.Close False
End If
Next
End Sub

3190496160

根据你的说明，数据源文件应该是只有一个，但是，看你的代码，又是目录中循环多个文件，那究竟是又一个还是多个？？

3190496160

Sub lqxs()
Dim ar, i&, wb As Workbook, r&
Dim rng As Range, br()
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "B.xls*")
    If f = "" Then MsgBox "找不到数据源文件！": Exit Sub
    Set rng = Sheet1.Columns(3).Find(Date, , , , , , 1)
    If Not rng Is Nothing Then MsgBox "不要重复拷贝！": Exit Sub
    Set wb = Workbooks.Open(p & f)
    ar = wb.Sheets(1).[c1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    wb.Close False
    For i = 2 To UBound(ar)
        If ar(i, 1) = Date Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(i, j)
            Next j
        End If
    Next i
    If n = "" Then MsgBox "数据源文件没有今天的数据！": Exit Sub
    r = Cells(Rows.Count, 3).End(xlUp).Row + 1
    Cells(r, 3).Resize(n, UBound(br, 2)) = br
    MsgBox "本次提取了" & n & "行数据"
    Application.ScreenUpdating = True
End Sub

3190496160

test.rar (48.24 KB, 下载次数: 5)

2021-1-17 13:47 上传

点击文件名下载附件

cmo9020

3190496160 发表于 2021-1-17 13:48

大神你好,抱歉,是一个B.XLS
刚测试一下,在请教2个问题
1.那像我B表的AB列如果有数据,会变成无法复制,我搞了好久还是没办法

2.如果1/17 原本笔数是2笔,有复制到A了临时B又增加了1笔=3笔
那A己经复制2笔了,有办法判断把B的新增那笔复制到A吗?谢谢

3190496160

cmo9020 发表于 2021-1-17 14:17
大神你好,抱歉,是一个B.XLS
刚测试一下,在请教2个问题
1.那像我B表的AB列如果有数据,会变成无法复制,我 ...

纯粹是多此一举，你直接增加到A表中不就行了吗

cmo9020

3190496160 发表于 2021-1-17 15:06
纯粹是多此一举，你直接增加到A表中不就行了吗