copy non contiguous cells with values and paste in another sheet

[k1dr0ck]

hi,

i would like to copy non contiguous (in different rows and columns) cells with data in sheet 1 and paste into a list in sheet 2 starting at A1

[BadlySpelledBuoy]

Attach a workbook showing what the data looks like before and after.

BSB

[swaatacba]

I tried to record a macro for copying non-contiguous cells, but got the following error message. In Excel 2013, at least this is a non-starter.

[beyond Excel]

Hello.
To be able to copy discontiguous cells:

- All cells must be in the same row, or
- All cells must be in the same column

It follows that if the selection has a diversity of rows or columns, the copy is not made.

[JEC.]

Maybe?

Sub jec()
 Dim sq(), ar, x As Long, j As Long, jj As Long
 ar = Sheets(1).UsedRange
 
 For j = 1 To UBound(ar)
   For jj = 1 To UBound(ar, 2)
     If ar(j, jj) <> "" Then
       ReDim Preserve sq(x)
       sq(x) = ar(j, jj)
       x = x + 1
     End If
   Next
 Next

 Sheets.Add.Cells(1).Resize(x) = Application.Transpose(sq)
End Sub

[k1dr0ck]

hi,

thanks for the replies, i used JEC's code it works

FYI
attached my sample workbook
sheet 1 is before
sheet 2 is after

@jec will add rep after I add rep to a different user, before this post apparently you were my last rep recipient

[k1dr0ck]

@jec


how can i display the result in a body of an email instead?
I'm trying below and it just says type mismatch

.body = "Hi" & vbNewLine & vbNewLine & sq

[k1dr0ck]

found a code tried it but it says subscript out of range

Sub email()

Dim sq(), ar, x As Long, j As Long, jj As Long
Dim y, sBody

 ar = Sheets(1).UsedRange
 
 For j = 1 To UBound(ar)
   For jj = 1 To UBound(ar, 2)
     If ar(j, jj) <> "" Then
       ReDim Preserve sq(x)
       sq(x) = ar(j, jj)
       x = x + 1
     End If
   Next
 Next

        sBody = "Hi,"
        Do While y <= x
          sBody = sBody & vbNewLine & sq(y)
          y = y + 1
        Loop
    
    With CreateObject("outlook.application").createitem(0)
       .To = "my@email.com"
       .Subject = "My subject"
       .body = sBody
       '.Attachments.Add
       .display '.send
    End With    

End Sub

[k1dr0ck]

just in case anyone is interested should have been

Do While y < x