PDA

View Full Version : [SOLVED] Need help restructuring macro to do opposite and adding to macro, please!



estatefinds
07-22-2017, 01:36 PM
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
07-22-2017, 02:17 PM
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
07-22-2017, 02:35 PM
Wow!!!! That worked Great!!!

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

Sincerely Dennis

p45cal
07-22-2017, 03:16 PM
(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
07-23-2017, 04:05 PM
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
07-24-2017, 12:01 AM
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