gpt4 book ai didi

excel - 从所有工作表中复制范围并将它们粘贴到新的工作表中

转载 作者:行者123 更新时间:2023-12-04 20:50:15 25 4
gpt4 key购买 nike

请帮助我,我需要复制不同的范围,直到所有工作表中的第一个空白单元格并将它们粘贴到新的单元格中。都在同一个Workbook .
这是我的尝试:

Sub Target()

Dim lRow As Long
Dim copyRange As Range
Dim sh As Worksheet
Dim shReport As Worksheet
Set shReport = ThisWorkbook.Worksheets("Target")

For Each sh In ThisWorkbook.Worksheets
Select Case sh.Name
Case Is <> "ALLProjectForReport"
lRow = shReport.Cells(Rows.Count, "B").End(xlUp).Row
Set copyRange = sh.Range("A3")

copyRange.Copy Destination:=shReport.Range("B" & lRow)

End Select
Next
Set shReport = Nothing
Set sh = Nothing
End Sub

最佳答案

堆叠部分列 ( xlDown )

Option Explicit

Sub createReport()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim dst As Worksheet: Set dst = wb.Worksheets("Target")
Dim cel As Range
Set cel = dst.Cells(dst.Rows.Count, "B").End(xlUp).Offset(1)

Dim src As Worksheet
Dim rng As Range
For Each src In wb.Worksheets
Select Case src.Name
Case "AllProjectForReport", "Target"
Case Else
With src.Range("A3")
Set rng = .End(xlDown)
If rng.Row < src.Rows.Count Then
Set rng = .Resize(rng.Row - .Row + 1)
Else
If Len(.Value) > 0 Then
Set rng = .Offset
Else
Set rng = Nothing
End If
End If
If Not rng Is Nothing Then
rng.Copy Destination:=cel
Set cel = cel.Offset(rng.Rows.Count)
End If
End With
End Select
Next

MsgBox "Report created.", vbInformation, "Success"

End Sub

关于excel - 从所有工作表中复制范围并将它们粘贴到新的工作表中,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/65746444/

25 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com