Excel VBA - 从一组单元格复制并粘贴到一个单元格

Question

我需要从sheet1的一系列单元格中复制内容，例如A1:A10，并将所有数据粘贴到sheet2中单个单元格A1中。

这似乎是一个简单的使用案例，但我迄今为止找不到任何解决方案。以下是我尝试过的方法：

' Attempt 1
Sheets("shee1").Select    
Range("A1:A10").Select
Selection.Copy
MsgBox Selection.Text ' Error: Type mismatch. If I add Selection.Text to watch I see an array kind of structure with each index having each cell data
Dim val = Selection.Text
Sheets("sheet2").Select
Range("A1") = val

' Attempt 2
Sheets("sheet1").Range("A1:A10").Copy(Sheets("sheet2").Range("A1") 'Doesn't copy in single cell A1, instead copies to multiple rows like in source

- Shiridish

---

可以使用CONCATENATE或TEXTJOIN函数。 - BigBen

... 或者 ARRAYTOTEXT(A1:A10)（自MS 365版本起可用） - T.M.

Answer 1

也许是这个？

Option Explicit

Sub Sample()
    Dim MyAr As Variant
    MyAr = Sheets("Sheet1").Range("A1:A10").Value2
    Sheets("sheet2").Range("A1").Value = Join(Application.Transpose(MyAr), vbLf)
End Sub

这将从区域中读取数据并将它们存入一个数组，然后在输出到相关区域前将它们连接起来。

- Siddharth Rout

Answer 2

将列数据复制到单元格

• 这三种解决方案都可以实现相同的功能。
• 请在常量部分调整数值。
• s - 源，d - 目标
• 简而言之：将列范围的值写入数组，然后将数组中的值写入字符串，最后将字符串写入目标单元格。

Option Explicit

Sub copyRangeData()
    
    Const sName As String = "Sheet1"
    Const sAddress As String = "A1:A10"
    
    Const dName As String = "Sheet2"
    Const dAddress As String = "A1"
    Const dDelimiter As String = vbLf
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(sAddress)
    Dim sData As Variant: sData = srg.Value
    
    Dim dstring As String
    Dim r As Long
    For r = 1 To UBound(sData, 1)
        dstring = dstring & sData(r, 1) & dDelimiter
    Next r
    dstring = Left(dstring, Len(dstring) - Len(dDelimiter))
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dCell As Range: Set dCell = dws.Range(dAddress)
    dCell.Value = dstring
    
End Sub

Sub copyRangeDataShorter()
    
    Const sName As String = "Sheet1"
    Const sAddress As String = "A1:A10"
    
    Const dName As String = "Sheet2"
    Const dAddress As String = "A1"
    Const dDelimiter As String = vbLf
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sData As Variant: sData = wb.Worksheets(sName).Range(sAddress).Value
    
    Dim dstring As String
    Dim r As Long
    For r = 1 To UBound(sData, 1)
        dstring = dstring & sData(r, 1) & dDelimiter
    Next r
    dstring = Left(dstring, Len(dstring) - Len(dDelimiter))
    
    wb.Worksheets(dName).Range(dAddress).Value = dstring
    
End Sub

Sub copyRangeDataShortest()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sData As Variant: sData = wb.Worksheets("Sheet1").Range("A1:A10").Value
    
    Dim dstring As String
    Dim r As Long
    For r = 1 To UBound(sData, 1)
        dstring = dstring & sData(r, 1) & vbLf
    Next r
    dstring = Left(dstring, Len(dstring) - 1)
    
    wb.Worksheets("Sheet2").Range("A1").Value = dstring
    
End Sub

- VBasic2008

---

++ 在我发布答案之后，我阅读了你的答案并意识到你已经涵盖了我发布的Sub copyRangeDataShortest()。如果你将其纳入你的答案中，那么我会删除我的答案 :) - Siddharth Rout

@Siddharth Rout：不要删除你的答案。我认为它是一个不同的有效解决方案，即使你可以将其作为一行代码呈现。你正在使用ActiveWorbook、.Value2和Application.Transpose。我最近才安装了64位Office，在这个答案中，当Transpose的元素数量大于65535时没有引发错误，这让我感到惊讶。因此，在我进一步调查之前，“它在我的书中的地位”有点不清楚。 - VBasic2008

Answer 3

您可以使用Chr(10)，它相当于Excel的Alt+Enter命令。这将设置单元格的WrapText为True并在下一行输入数据。

Sub MultipleCells_To_OneCell()
    Dim cell As Range, SelectedRange As Range

    ThisWorkbook.Worksheets("Sheet2").Activate

    Set SelectedRange = ThisWorkbook.Worksheets("Sheet2").Range("A1:A10")

    For Each cell In SelectedRange
        ThisWorkbook.Worksheets("Sheet3").Range("A1").Value = ThisWorkbook.Worksheets("Sheet3").Range("A1") _
            & Chr(10) & cell
    Next cell
End Sub

希望这能对你有所帮助。

- Anmol Kumar

---

使用命名为 vbLf 的换行符更佳。最好在本地变量中累积字符串，并仅更新目标单元格一次。 - Joffan