跨薄复制保留公式

wqhsz385919

请路过大侠帮忙看下：
从NAS中按料号复制源表中的明细，保留公式，使用UNION提高效率，但如果有多条不是连续的，隔了行，则粘贴就变成了数值。
源表不想排序，请大侠帮忙看下，多谢！
以下是学着写的代码：
Private Sub CommandButton21_Click()
Dim rng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
p = "\\snas\bg\中心\交付文件夹\小客户\2.量产报价\报价汇总表"
endrow = Range("a12").End(xlUp).Row
arr = Range("b2:b" & endrow)
Range("a13").CurrentRegion.Offset(1).ClearContents
Set wb = Workbooks.Open(p & "\报价汇总清单2024模拟表.xlsx")
With wb.Sheets("汇总")
     r = .Range("b10000").End(3).Row
     brr = .Range("b1:b" & r)
     For i = 2 To UBound(arr)
         s = IIf(InStr(arr(i, 1), "."), Left(arr(i, 1), Len(arr(i, 1)) - 3), arr(i, 1))
         
         For j = 2 To UBound(brr)
             If InStr(brr(j, 1), s) <> 0 Then
                If rng Is Nothing Then
                   Set rng = .Cells(j, 2).Offset(, -1).Resize(1, 30)
                Else
                   Set rng = Union(rng, .Cells(j, 2).Offset(, -1).Resize(1, 30))
               End If
             End If
         Next
      Next
  If Not rng Is Nothing Then
     rng.Copy
     Range("a14").PasteSpecial Paste:=xlPastevalueandnumberformats
     aa = MsgBox("是否需要删除源数据避免上传后重复", vbYesNo + vbExclamation)
     If aa = vbNo Then GoTo end100
     rng.Delete shift:=xlDown
  Else
   MsgBox "查无数据！"
End If
end100:
End With
wb.Close True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "OK!"
End Sub

ykcbf1100

rng.Copy
Range("a14").PasteSpecial Paste:=xlPastevalueandnumberformats
以上代码改成：rng.copy [a14]

ykcbf1100

求助最好有附件，没附件没法调试代码的。

wqhsz385919

ykcbf1100 发表于 2024-8-20 20:26
求助最好有附件，没附件没法调试代码的。

谢谢大侠关注，我加了附件，看下附件 ，谢谢！
使用的是WPS