Excel VBA - 从一系列单元格中复制并粘贴到一个单元格中

Question

I need to copy content from a range of cells in sheet1 , say A1:A10 , and paste all the data in a single cell in sheet2 in cell A1 This seems to be a simple use case but I couldn't find any solution so far. Below is what I tried

' 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

Answer 1

Perhaps this?

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

This reads the range into an array and then joins them before writing the output to the relevant range.

Answer 2

Copy Column Data to Cell

• All three solutions do the same thing.
• Adjust the values in the constants section.
• s - Source, d - Destination
• In a nutshell: writes the values of a column range to an array, then writes the values from the array to a string, and then writes the string to the destination cell.

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

Answer 3

You can use Chr(10) which is equivalent to excel Alt + Enter command. It would set cells WrapText to True and enters data in next line.

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

Hope this would help you.