Need help restructuring macro to do opposite and adding to macro, please!

[estatefinds]

I have maccro that currently puts columns to rows from Column A, to B and C , and D

I need the maccro to be restructured to copy the Rows from within the range of E1 to AL9548 , (But only the data that is highlighted) to be placed in the designated Column AN. I am attaching file.

Thank you very much in advance!!!

here is the code I currently have



[Sub movetocolumns()Dim i As Integer, iRow As Integer
Dim arrSource As Variant


'Set the first row
iRow = 1


With ActiveWorkbook.Worksheets("Sheet1")
'get the data into an array from the first column
arrSource = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))


'parse every value of the array and add the data to the next column
For i = 1 To (UBound(arrSource) - UBound(arrSource) Mod 3) Step 3
.Cells(iRow, 2) = arrSource(i, 1)
.Cells(iRow, 3) = arrSource(i + 1, 1)
.Cells(iRow, 4) = arrSource(i + 2, 1)
iRow = iRow + 1
Next i
'add the remaining values
Select Case UBound(arrSource) Mod 3
Case 1 'one item to add
.Cells(iRow, 2) = arrSource(i, 1)
Case 2 'still two items to add
.Cells(iRow, 2) = arrSource(i, 1)
.Cells(iRow, 3) = arrSource(i + 1, 1)
Case Else 'nothing to add
End Select
End With
End Sub]

[Leith Ross]

Hello estatefinds,

This will do the job.

Sub TestA()


    Dim Cell As Range
    Dim n    As Long
    Dim Rng  As Range
    
        Set Rng = ActiveSheet.Range("E1:AL9548")
        
        Application.ScreenUpdating = False
        
        For Each Cell In Rng
            If Cell <> "" Then
                n = n + 1
                Cell.Copy
                ActiveSheet.Cells(n, "AN").PasteSpecial xlPasteAll
                ActiveSheet.Cells(n, "AN").PasteSpecial xlPasteColumnWidths
            End If
        Next Cell
        
        Application.ScreenUpdating = True
        
End Sub

[estatefinds]

Wow!!!! That worked Great!!!

That is a good code!!!
Thank you Very much!!!

Sincerely Dennis

[p45cal]

(But only the data that is highlighted)

Try (adapted from Leith's code):

Sub TestA_v2()
Dim Cll As Range
Dim n As Long
Application.ScreenUpdating = False
With ActiveSheet
  For Each Cll In .Range("E1:AL9548").SpecialCells(xlCellTypeConstants, 3)
    If Cll.Interior.ColorIndex <> xlNone Then
      n = n + 1
      Cll.Copy .Cells(n, "AN")
    End If
  Next Cll
End With
Application.ScreenUpdating = True
End Sub

It assumes all values in the source range are plain values and not the result of formulae. Also that 'higlighted' means any background colour other than none.
By the way your existing code can be shortened/simplified:

Sub mtcs2()
Dim i As Long, arrSource, destnrng As Range, v

With ActiveSheet
  arrSource = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
  Set destnrng = Range("B1").Resize((UBound(arrSource) + 1) / 3, 3)
  i = 1
  For Each v In arrSource
    destnrng.Cells(i) = v
    i = i + 1
  Next v
End With
End Sub

[estatefinds]

to P45Cal, this code worked great, the highlighted data to column worked perfectly!!! Thank you for this addition on"Try (adapted from Leith's code):"
Thank you very much!!! Good Job!!!

[snb]

Please use code tags !!!

Sub M_snb()
   sn = Cells(1, 5).CurrentRegion
   ReDim sp(UBound(sn) * 3 - 1, 0)
   
   For j = 0 To UBound(sp)
     sp(j, 0) = sn(j \ 3 + 1, j Mod 3 + 1)
     Cells(1, 10).Offset(j).Interior.ColorIndex = Cells(1, 5).Offset(j \ 3, j Mod 3).Interior.ColorIndex
   Next
   
   Cells(1, 10).Resize(UBound(sp)) = sp
End Sub