Copy & Paste Dynamic Range to New Worksheet

[spencerp237]

I need a macro that copies that highlighted data to a new worksheet. In sheet 2, columns A (C1) and B (C2) would contain the data in row 2 from sheet 1. Column C (C3) would have the date from column D in sheet 1. Column D (C4) would have the number value that matches columns A:C.

The amount of highlighted rows will constantly be changing so I was thinking about using a For loop. Right now I have this to create a new worksheet for the data to be copied to with the desired headings.

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Sheet2"
With Sheets("Sheet2")
    .Cells(1, 1).Value = "C1"
    .Cells(1, 2).Value = "C2"
    .Cells(1, 3).Value = "C3"
    .Cells(1, 4).Value = "C4"
End With

My first thought for the For loop would be to do something like

For i = 3 To Cells.Highlight = False

However after this I'm not sure how to correctly capture all the data I need to. If everything was in one row that would be easy for me, I just don't know how to properly split up the data.

I've attached a sample workbook with Sheet 2 being the desired output. Any help or tips would be most appreciated Feel free to ask any questions for clarification.

[mdmackillop]

Sub Test()
    Dim r As Range
    Dim sh As Worksheet, WS1 As Worksheet
    Dim x As Long, y As Long, i As Long, j As Long, c As Long


    Set WS1 = ActiveSheet
    Set r = Selection
    c = r.Cells(1, 1).Column + 1


    x = r.Rows.Count
    y = r.Columns.Count


    Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    sh.Range("A1:D1") = Array("C1", "C2", "C3", "C4")
    For i = 0 To x - 1
        For j = 0 To y - 2
        sh.Cells(2, 1).Offset(j * x).Resize(x) = WS1.Cells(2, c + j)
        sh.Cells(2, 2).Offset(j * x).Resize(x) = WS1.Cells(2, c + j)
        sh.Cells(2, 3).Offset(j * x).Resize(x) = r.Columns(1).Value
        sh.Cells(2, 4).Offset(j * x).Resize(x) = r.Columns(2 + j).Value
        Next j
    Next i
End Sub

[Paul_Hossler]

Or this

Option Explicit
Sub Test2()
    Dim rData As Range
    Dim ws2 As Worksheet, ws1 As Worksheet
    Dim i As Long, r As Long, c As Long
         
         
    If Not TypeOf Selection Is Range Then Exit Sub
         
    If Selection.CurrentRegion.Cells.Count = 1 Then Exit Sub
         
    Set rData = Selection.CurrentRegion
    
    If rData.Rows.Count < 3 Or rData.Columns.Count < 3 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Set ws1 = ActiveSheet
     
    Set ws2 = Sheets.Add(after:=Sheets(Sheets.Count))
    ws2.Range("A1:D1") = Array("C1", "C2", "C3", "C4")
    
    i = 2
    
    With rData
        For c = 2 To .Columns.Count
            For r = 2 To .Rows.Count
                If .Cells(r, c).Interior.ColorIndex <> xlColorIndexNone Then
                    ws2.Cells(i, 1).Value = .Cells(1, c).Value
                    ws2.Cells(i, 2).Value = .Cells(1, c).Value
                    ws2.Cells(i, 3).Value = .Cells(r, 1).Value
                    ws2.Cells(i, 4).Value = .Cells(r, c).Value
                    i = i + 1
                End If
            Next r
        Next c
    End With
    
    Application.ScreenUpdating = True
End Sub