PDA

View Full Version : Copy & Paste Dynamic Range to New Worksheet



spencerp237
03-09-2017, 12:03 PM
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 https://www.excelforum.com/images/smilies/smile.gif Feel free to ask any questions for clarification.

mdmackillop
03-10-2017, 08:56 AM
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
03-10-2017, 10:11 AM
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