VBA Code to Copy/Paste to a new sheet.

[datavizwiz]

Hi guys!

I am in need of VBA code that will copy data from one sheet and paste it into another sheet with some slight modifications...

I have some data that is in the current format ofColumns A through N)

[TABLE="width: 2101"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Employee ID[/TD]
[TD] Weekly Start Date 1[/TD]
[TD] Weekly End Date 1[/TD]
[TD] Weekly Start Date 2[/TD]
[TD] Weekly End Date 2[/TD]
[TD] Weekly Start Date 3[/TD]
[TD] Weekly End Date 3[/TD]
[TD] Daily Start Date 1[/TD]
[TD] Daily End Date 1[/TD]
[TD] Daily Start Date 2[/TD]
[TD] Daily End Date 2[/TD]
[TD]Daily Start Date 3[/TD]
[TD]to Daily End Date 3[/TD]
[/TR]
[TR]
[TD]Test Name[/TD]
[TD]U37505[/TD]
[TD="align: right"]5/10/2019[/TD]
[TD="align: right"]5/12/2019[/TD]
[TD="align: right"]5/9/2019[/TD]
[TD="align: right"]5/11/2019[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]5/31/2019[/TD]
[TD="align: right"]6/1/2019[/TD]
[TD="align: right"]5/31/2019[/TD]
[TD="align: right"]5/31/2019[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

That I need to be in the format of:

Employee ID: Vacation ID: Start Date: End Date:

U37505 Weekly 1 5/10/2019 5/12/2019
U37505 Weekly 2 5/9/2018 5/11/2019

I also need to make sure that if there are blank fields that they reflect accurately.

I was trying to modify this code that someone on this site provided me for another project, but my VBA skills are mediocre and I'm on a time constraint so I was hoping one of you lovely folks here could help me!

 

[datavizwiz]

This is the code that I've been trying to modify, but it is set to paste all of the dates into one column instead of splitting the data (every other column) into two different columns.

Sub FillData()
Application.ScreenUpdating = False
Dim LastRow As Long ‘
LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim LastRow2 As Long
Dim lColumn As Long, ID As Range
lColumn = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
Sheets("Sheet2").Range("A1:C1") = Array("ID", "Schedule ID", "Ranking")
For Each ID In Sheets("Sheet1").Range("B2:B" & LastRow)
LastRow2 = Sheets("Sheet2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Sheets("Sheet2").Cells(LastRow2, 1).Resize(lColumn - 2) = ID
Sheets("Sheet1").Range(Cells(1, 3), Cells(1, lColumn)).Copy
Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
ID.Offset(0, 1).Resize(1, lColumn - 2).Copy
Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next ID
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[JLGWhiz]

Try this

Sub t()
Dim lc As Long, i As Long, x As Long, sh1 As Worksheet, sh2 As Worksheet
Set sh1 = ActiveSheet
Set sh2 = Sheets.Add
With sh1
    lc = .Cells(1, Columns.Count).End(xlToLeft).Column
    For Each c In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
        x = 0
        For i = 3 To lc - 1 Step 2
            x = x + 1
            sh2.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
            sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = "Weelkly" & x
            sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 2).Resize(, 2) = .Cells(c.Row, i).Resize(, 2).Value
        Next
    Next
End With
End Sub

 

[rpaulson]

another option

Sub Doit()

Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Worksheets("Sheet1")
Set s2 = Worksheets("Sheet2")

lr = s1.Cells(Rows.Count, "B").End(xlUp).Row

For r = 2 To lr
ID = s1.Cells(r, "B")

w = 1
For c = 3 To 13 Step 2
wr = s2.Cells(Rows.Count, "A").End(xlUp).Row + 1

If c = 9 Then w = 1
If c >= 9 Then txt = "Daily " Else txt = "Weekly "


s2.Cells(wr, "A") = ID
s2.Cells(wr, "B") = txt & w
s2.Cells(wr, "C") = s1.Cells(lr, c)
s2.Cells(wr, "D") = s1.Cells(lr, c)
w = w + 1
Next c
Next r

End Sub

hth,

Ross

 

[datavizwiz]

Thanks guys!

Both of these work great! I am so happy that people are willing to share their knowledge on this site. This is at least a 4 hour time savings for me!

Thanks for the quick reply!

 

[rpaulson]

you see - not everyone in OHIO is a Michigan hater! GO BUCKS!!!