提取和复制列

ddz79101

老师，有3个表，希望将sheet1中的指定3列提取嵌入到sheet2的指定空列中，并将结果（不含公式和有效性）粘贴到sheet3中。因为放置的列不连续，且不含公式的粘贴，望老师指教。谢谢！

ykcbf1100

参与一下，代码以附件为准。

1. Sub ykcbf()  '//复制
   
2.     Dim arr, brr
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, "g").End(3).Row
   
5.         arr = .Range("g6:g" & r)
   
6.         brr = .Range("h6:i" & r)
   
7.     End With
   
8.     With Sheets("Sheet2")
   
9.         .[e5].Resize(UBound(arr), 1) = arr
   
10.         .[h5].Resize(UBound(brr), 2) = brr
    
11.     End With
    
12.     MsgBox "OK！"
    
13. End Sub
    
14. 
    

复制代码

ykcbf1100

附件供参考。。。

ddz79101

ykcbf1100 发表于 2024-1-22 07:44
附件供参考。。。

谢谢老师！第1步即将sheet复制到sheet2运行成功，能否再将第二步就是在将sheet2复制到sheeet3，单元格中的公式和有效性不要。谢谢老师持续的帮助。

ddz79101

ykcbf1100 发表于 2024-1-22 07:44
附件供参考。。。

老师！可以再帮我解决下步复制含有公式，有效性的列，但簿粘贴公式，有效性

ykcbf1100

ddz79101 发表于 2024-1-22 10:23
老师！可以再帮我解决下步复制含有公式，有效性的列，但簿粘贴公式，有效性

你表2复制到表3的数据范围是哪些呢？

ddz79101

ykcbf1100 发表于 2024-1-22 10:37
你表2复制到表3的数据范围是哪些呢？

谢谢老师！我以为你下线了喃,所以又另立题重发了！
老师我希望复制：单号，摘要，品名，收入，支出列，只是类型列不复制

ykcbf1100

ddz79101 发表于 2024-1-22 10:47
谢谢老师！我以为你下线了喃,所以又另立题重发了！
老师我希望复制：单号，摘要，品名，收入，支出列， ...

改好了。。。

ddz79101

ykcbf1100 发表于 2024-1-22 11:00
改好了。。。

谢谢老师！我设想分二步是写2个代码，因为第1步和第2步中间有个手工填写步骤。老师的代码是将2者合二为一了，我是要分开。我试图修改老师的代码，但没有成功。望老师再指点：
Sub ykcbf()  '//¸′ÖÆ
    Dim arr, brr
    With Sheets("Sheet2")
        .[d6].Resize(UBound(arr), 1) = arr
        .[e6].Resize(UBound(arr), 2) = arr
        .[g6].Resize(UBound(brr), 1) = brr
        .[h6].Resize(UBound(brr), 2) = brr
        .[i6].Resize(UBound(brr), 3) = brr
        r = .Cells(Rows.Count, "d").End(3).Row
        arr = .Range("d5:e" & r)
        brr = .Range("g5:i" & r)
    End With
    With Sheets("Sheet3")
        .Columns(4).NumberFormatLocal = "@"
        .[d6].Resize(UBound(arr), 2) = arr
        .[f6].Resize(UBound(brr), 3) = brr
    End With
    MsgBox "OK￡¡"
End Sub

ddz79101

ykcbf1100 发表于 2024-1-22 11:00
改好了。。。

谢谢老师！因为第1步和第2不中间有个手工填写的过程，所以我希望将sheet2复制到hsheet3贷代码单独写，我试图修改老师的代码，但没有成功：
Sub ykcbf()  '//¸′ÖÆ
    Dim arr, brr
    With Sheets("Sheet2")
        .[d6].Resize(UBound(arr), 1) = arr
        .[e6].Resize(UBound(arr), 2) = arr
        .[g6].Resize(UBound(brr), 1) = brr
        .[h6].Resize(UBound(brr), 2) = brr
        .[i6].Resize(UBound(brr), 3) = brr
        r = .Cells(Rows.Count, "d").End(3).Row
        arr = .Range("d5:e" & r)
        brr = .Range("g5:i" & r)
    End With
    With Sheets("Sheet3")
        .Columns(4).NumberFormatLocal = "@"
        .[d6].Resize(UBound(arr), 2) = arr
        .[f6].Resize(UBound(brr), 3) = brr
    End With
    MsgBox "OK￡¡"
End Sub
但没有成功，望老师看看。