如何更新表1内容自动加在表2的每一项对应内容

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.8.30
   
2.     b = [{"b3","c4","e4","c5","c6","e6","c7","e7"}]
   
3.     ReDim brr(1 To 1, 1 To UBound(b))
   
4.     With Sheets("申请单")
   
5.         For i = 1 To UBound(b)
   
6.             brr(1, i) = .Range(b(i)).Value
   
7.              .Range(b(i)).Value = ""
   
8.         Next
   
9.     End With
   
10.     With Sheets("资料印制汇总表")
    
11.         r = .Cells(Rows.Count, 1).End(3).Row
    
12.         .Cells(r + 1, 1).Resize(, UBound(b)) = brr
    
13.     End With
    
14.     MsgBox "已保存更新！"
    
15. End Sub
    

复制代码

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub CopyToSummary()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim nextRow As Long
    Dim rng As Range
    ' 设置工作表变量
    Set wsSource = ThisWorkbook.Sheets("申请单") ' 申请单工作表名称
    Set wsDest = ThisWorkbook.Sheets("资料印制汇总表") ' 汇总表名称
   
    ' 找到汇总表的下一个空白行
    nextRow = wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Row + 1
   
    ' 复制申请单的内容到汇总表
    With wsSource
        arr = Split("b3 c4 e4 c5 c6 e6 c7 e7")
        ReDim brr(1 To 1, 1 To UBound(arr) + 1)
        For i = 0 To UBound(arr)
            If rng Is Nothing Then
                Set rng = .Range(arr(i))
                brr(1, i + 1) = .Range(arr(i))
            Else
                Set rng = Union(rng, .Range(arr(i)))
                brr(1, i + 1) = .Range(arr(i))
            End If
        Next
    End With
    wsDest.Cells(nextRow, 1).Resize(, UBound(brr, 2)) = brr
   
   
    For Each rg In rng
        If rg.MergeCells Then rg.MergeArea.Cells(1) = Empty Else rg.ClearContents        '清除申请表中输入的内容，看实际需要
    Next
    Beep
   
   
End Sub

fylsg80

ykcbf1100 发表于 2024-8-30 16:32
附件供参考。。。

谢谢！

fylsg80

quqiyuan 发表于 2024-8-30 16:46
参与一下，仅供参考。。。

谢谢！

从此海蓝

在原版上也改了一个练练：
Sub CopyToSummary()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim nextRow As Long
   
    '设置工作表变量
    Set wsSource = ThisWorkbook.Sheets("申请单") ' 申请单工作表名称
    Set wsDest = ThisWorkbook.Sheets("资料印制汇总表") ' 汇总表名称
   
    '找到汇总表的下一个空白行
    nextRow = wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Row + 1
   
    '复制申请单的内容到汇总表
    wsDest.Cells(nextRow, 1).Value = wsSource.Range("B3").Value ' 编号
    wsDest.Cells(nextRow, 2).Value = wsSource.Range("C4").Value ' 申请时间
    wsDest.Cells(nextRow, 3).Value = wsSource.Range("E4").Value ' 申请部门
    wsDest.Cells(nextRow, 4).Value = wsSource.Range("C5").Value ' 打印（复印）名称
    wsDest.Cells(nextRow, 5).Value = wsSource.Range("C6").Value ' 印制数量
    wsDest.Cells(nextRow, 6).Value = wsSource.Range("E6").Value ' 申请部门签字
    wsDest.Cells(nextRow, 7).Value = wsSource.Range("C7").Value ' 教导处签字
    wsDest.Cells(nextRow, 8).Value = wsSource.Range("E7").Value ' 副校长签字
    wsDest.Cells(nextRow, 9).Value = "" '备注
    '依次添加更多的列复制操作，具体视你的表格结构而定
   
    '清除申请单中的内容（可选）
    With wsSource
        .Range("b3") = ""
        .Range("c4") = ""
        .Range("e4") = ""
        .Range("c5") = ""
        .Range("c6") = ""
        .Range("e6") = ""
        .Range("c7") = ""
        .Range("e7") = ""
    End With
        
End Sub

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, r&
   
    br = [{"B3","C4","E4","C5","C6","E6","C7","E7"}]
    ReDim ar(1 To UBound(br))
   
    With Worksheets("申请单")
        For j = 1 To UBound(br)
            ar(j) = .Range(br(j)).Value
        Next j
    End With
   
    With Worksheets("资料印制汇总表")
        r = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        .Cells(r, 1).Resize(, UBound(ar)) = ar
        .Activate
    End With

    Beep
End Sub

gwjkkkkk

..............

fylsg80

从此海蓝 发表于 2024-8-30 18:27
在原版上也改了一个练练：
Sub CopyToSummary()
    Dim wsSource As Worksheet

非常感谢！